Home » Forums » Open Source Learning Center » Question and Answer

Vishsesh Need few changes in macro code

Submitted by bunty_1244 on 7 March, 2011 - 16:15

Hello Vishesh,

Sorry to bother you again. But I need few changes in the code. If you look at attached sheet you will see that T-1 does not have row H so in "After" H has no value simillarly T-2 does not have G and I so in "After" G and I has no data. It should just match and line up A to A, B to B and so on... Could you please update the code? It is included in the attached sheet.

Expecting your positive answer.

Thanks and Regards..

AttachmentSize
Test.xls37 KB
‹ Copy from one workbook to another but only certain columns Want a formula or a macro ›
»
Vishesh's picture

Replace with this code

Submitted by Vishesh on 7 March, 2011 - 17:02.
Replace the code that you have with this one... 
Sub CreateData()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
 
    '------------------
    With ThisWorkbook.Worksheets("Sheet1") 'Change the sheet name
        Call CompareNCopy(.Range("B7"), .Range("H7"), .Range("B18")) 'For T-1 provide your own range if it changes
        Call CompareNCopy(.Range("H7"), .Range("B7"), .Range("H18")) 'For T-2
    End With
    '=================
    
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Sub CompareNCopy(rngOrg As Range, rngFrom As Range, rngTarget As Range)
    Dim rngCell     As Range
    Dim intMatch    As Integer
 
    rngTarget.CurrentRegion.Clear 'Clear the target range
    
    rngOrg.CurrentRegion.Copy
    rngTarget.PasteSpecial xlPasteAll
 
    For Each rngCell In rngFrom.CurrentRegion.Columns(1).Cells
        intMatch = 0
        On Error Resume Next
        intMatch = Application.WorksheetFunction.Match(rngCell.Value, rngOrg.CurrentRegion.Columns(1).Cells, 0)
        On Error GoTo 0
        If intMatch = 0 Then
            'rngCell.Resize(, rngFrom.CurrentRegion.Columns.Count).Copy
            rngCell.Resize(, 1).Copy
            rngTarget.End(xlDown).Offset(1).PasteSpecial xlPasteAll
        End If
    Next rngCell
    Application.CutCopyMode = False
 
    rngTarget.CurrentRegion.Sort Key1:=rngTarget, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
    Set rngCell = Nothing
End Sub
»