Find and copy data with a keyword from multiple workbooks into the master workbook

Copy Multiple Workbook Column Ranges

  • Not tested.
  • Before running the code adjust the values in the constants section.
  • Opens each workbook in a specified folder and in its first worksheet copies the non-empty column range below the cell containing a specified string to a specified column in another worksheet of an already open workbook.
  • The code is in a different (off course open) workbook (concluded due to Filename.xlsx).

The Code

Option Explicit
    
Sub looping_through999()
    
    Const wbName As String = "Filename.xlsx"
    Const wsName As String = "Sheetname"
    Const tgtCol As Variant = "D"
    Const FolderPath As String = "H:\folder_path\"
    Const Criteria As String = "VARIEDAD"
    Const FileExtension As String = "*.xls"
   
    Dim Target As Worksheet
    Set Target = Workbooks(wbName).Worksheets(wsName)
    
    Dim src As Range       ' Source Columns Range
    Dim srcFirst As Range  ' Source First Cell Range
    Dim srcLast As Range   ' Source Last Cell Range
    Dim tgt As Range       ' Target Column Range
    Dim FileName As String ' Current Source File Name
    
    FileName = Dir(FolderPath & FileExtension)
    Do While FileName <> ""
        With Workbooks.Open(FileName:=FolderPath & FileName).Worksheets(1)
            Set srcFirst = .Cells.Find(What:=Criteria, _
                                       After:=.Cells(.Rows.Count, _
                                                     .Columns.Count), _
                                       LookIn:=xlFormulas, _
                                       LookAt:=xlWhole, _
                                       SearchOrder:=xlByRows) _
                                 .Offset(1)
            Set srcLast = .Cells(.Rows.Count, srcFirst.Column).End(xlUp)
            Set src = .Range(srcFirst, srcLast)
            Set tgt = Target.Cells(Target.Rows.Count, tgtCol) _
                            .End(xlUp).Offset(1).Resize(src.Rows.Count)
            tgt.Value = src.Value
            .Close SaveChanges:=False
        End With
        FileName = Dir
    Loop
    
    ' Note that Target is a worksheet and its parent is the workbook.
    ' Save Target Workbook.
    'Target.Parent.Save
    
    MsgBox "Column data transferred.", vbInformation, "Success"

End Sub

CLICK HERE to find out more related problems solutions.

Leave a Comment

Your email address will not be published.

Scroll to Top