Copy a column or columns from each workbook in a folder using VBA in Microsoft Excel

Sub CopyColumn ()
    Dim basebook As Workbook
    Dim mybook As Workbook
    Dim sourceRange As Range
    Dim destrange As Range
    Dim cnum As Integer
    Dim i As Long
    Dim a As Integer
    Application.ScreenUpdating = False
    With Application.FileSearch
        .NewSearch
        .LookIn = "C:Data"
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute() > 0 Then
            Set basebook = ThisWorkbook
            cnum = 1
            For i = 1 To .FoundFiles.Count
                Set mybook = Workbooks.Open(.FoundFiles(i))
                Set sourceRange = mybook.Worksheets(1).Columns("A:B")
                a = sourceRange.Columns.Count
                Set destrange = basebook.Worksheets(1).Cells(1, cnum)
                sourceRange.Copy destrange
                mybook.Close
                cnum = i * a + 1
            Next i
        End If
    End With
    Application.ScreenUpdating = True
End Sub

Sub CopyColumnValues()
    Dim basebook As Workbook
    Dim mybook As Workbook
    Dim sourceRange As Range
    Dim destrange As Range
    Dim cnum As Integer
    Dim i As Long
    Dim a As Integer
    Application.ScreenUpdating = False
    With Application.FileSearch
        .NewSearch
        .LookIn = "C:Data"
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute() > 0 Then
            Set basebook = ThisWorkbook
            cnum = 1
            For i = 1 To .FoundFiles.Count
                Set mybook = Workbooks.Open(.FoundFiles(i))
                Set sourceRange = mybook.Worksheets(1).Columns("A:B")
                a = sourceRange.Columns.Count
                With sourceRange
                    Set destrange = basebook.Worksheets(1).Columns(cnum). _
                                    Resize(, .Columns.Count)
                End With
                destrange.Value = sourceRange.Value
                mybook.Close
                cnum = i * a + 1
            Next i
        End If
    End With
    Application.ScreenUpdating = True
End Sub

Add a Comment

Your email address will not be published. Required fields are marked *