Question : Copy data from multiple workbooks with VBA

Hi Experts,

Please advice how to copy multiple workbooks into single spreadsheet with VBA code, here are the details:

Workbook_A, Sheet-1 (B2:H6) to Workbook_Database, Sheet-1 (B2:H6)
Workbook_B, Sheet-1 (B2:H6) to Workbook_Database, Sheet-1 (B7:H11)
Workbook_C, Sheet-1 (B2:H6) to Workbook_Database, Sheet-1 (B12:H16)
Workbook_D, Sheet-1 (B2:H6) to Workbook_Database, Sheet-1 (B16:H21)
Workbook_D, Sheet-1 (B2:H6) to Workbook_Database, Sheet-1 (B22:H27)

Hope you can help me.

Answer : Copy data from multiple workbooks with VBA

Here is the code. Just replace it with the other one.

I saw that you missunderstand me about the workbook count. Don't put "TotalCountofWorkbooks +1" on the do while line. you should yourself calculate it and put the number over there
So if you have 6 files to open then the right number should be 7.If you have 10 files to open then the right number should be 11.

Cheers,
TK

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:

           
           
             Sub Copy_Paste()

    Dim WB As Workbook
    Dim objFileDLG As Office.FileDialog
    Dim strFilePath, lnLoop, lnLineNo, lcTargetCell
    
    Set objFileDLG = Application.FileDialog(msoFileDialogFilePicker)
    lnLoop = 1
    lnLineNo = 2
    
    Do While lnLoop < 6
        With objFileDLG
            .Filters.Add "Excel Files", "*.xls", 1
            .FilterIndex = 1
            .AllowMultiSelect = False
            .Title = "Select The Workbook to copy From "
            If .Show() <> 0 Then
                strFilePath = .SelectedItems(1)
            End If
        End With
        
        Set WB = Workbooks.Open(strFilePath)
        WB.Activate
        WB.Worksheets(1).Range("B2:H6").Copy
        Select Case lnLoop
            Case 1
                lcTargetCell = "B2"
            Case 2
                lcTargetCell = "B7"
            Case 3
                lcTargetCell = "B12"
            Case 4
                lcTargetCell = "B16"
            Case 5
                lcTargetCell = "B22"
     
        End Select
        
        ThisWorkbook.Worksheets(1).Activate
        Range(lcTargetCell).Activate
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                   xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        lnLoop = lnLoop + 1
        WB.Close
        Set WB = Nothing
        
    Loop
End Sub

           
         

Open in New Window

Select All