Macro to Vlookup, Filter matching values, move out the rows to another WB based on header RRS feed

  • Question

  • hi,

    I've 3 Workbook files in same folder. I'm looking to VLOOKUP CONCAT COLUMN "CL".

    WB1 has 90 columns

    WB2 has 95 columns

    WB3 has 99 columns

    If VLOOKUP in WB1 match with WB2, filter and copy out visible matching rows from WB1 into WB3 and then delete the visible rows from WB1.

    **Note WB1 need to copy from column A to M into WB3. At WB3, column N need to insert remarks "Invalid transaction"

    **WB1 Continue to copy from column N to CG into WB3 at column O.

    If there is not enough rows exceed 1 million, copy to a new workbook call WB3-1

    Following code can copy all data from one worksheet to another worksheet according to header name.

    But now i need to copy to another workbook after inserting vlookup code using vba. (work between 3 excel files).

    Appreciate some guidance and will be helpful if anyone has some code that can work well.

    Sub CopyColHeader()
     Dim SrcWS As Worksheet
     Dim TgtWS As Worksheet
     Dim SrcColHdrs As Range
     Dim srcCel As Range
     Dim TgtColHdrs As Range
     Dim srcLC As Long
     Dim tgtLC As Long
     Dim chgCnt As Long
     Dim newCnt As Long
     Dim c As Range
     chgCnt = 0
     newCnt = 0
     Set SrcWS = Sheets("WS1")
     Set TgtWS = Sheets("WS2")
     With SrcWS
     srcLC = .Cells(2, Columns.Count).End(xlToLeft).Column
     Set SrcColHdrs = .Range(.Cells(1, "B"), .Cells(1, srcLC))
     End With
     With TgtWS
     tgtLC = .Cells(2, Columns.Count).End(xlToLeft).Column
     Set TgtColHdrs = .Range(.Cells(1, "B"), .Cells(1, tgtLC))
     End With
     Application.ScreenUpdating = False
     For Each srcCel In SrcColHdrs
     Set c = TgtColHdrs.Find(srcCel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
     If Not c Is Nothing Then
     chgCnt = chgCnt + 1
     TgtWS.Cells(1, c.Column).PasteSpecial
     newCnt = newCnt + 1
     TgtWS.Cells(1, tgtLC + 1).PasteSpecial
     tgtLC = tgtLC + 1
     End If
     Next srcCel
     Application.CutCopyMode = False
     Application.ScreenUpdating = True
    End Sub

    Monday, February 17, 2020 3:08 PM