VBA to copy cell data from same worksheet in multiple workbooks within a folder.

**lee_har** · 07-25-2017, 09:58 AM

Hi All,
What I need to do is copy the data from cells A2 & B2 in the worksheet “BOM” from all the workbooks within a given folder - Q:\AX SYSTEM\Excel to AX via Schedule\count BOMs\ & paste it into a list in the worksheet “Sheet1” of workbook “Count Cores”.
Pasted data will start in cells A2 & B2 then continue down through A3 & B3, A4 & B4 etc until all workbooks from the folder have been copied & pasted.

Other cells within “Sheet1” are populated & will run calculations based on this list but hopefully I can actually do that bit 😉

Thanks in advance for any help offered.

Lee

**nigelog** · 07-25-2017, 10:15 AM

Public Sub CallData()
    
    Dim strFile   As String
    Dim strPath   As String
    Dim Found     As Range
    Dim i         As Long
    Dim j         As Long
    Dim ws        As Worksheet
    Dim NextRow   As Long
    
    Set ws = ActiveSheet    'Destination worksheet
    NextRow = ws.Range("A" & Rows.Count).End(xlUp).Row
    strPath = "P:\My Documents\Transport Figures\Year\"
    
    Application.ScreenUpdating = False
    
    For i = 27 To 78
        j = IIf(i < 53, i, i - 52)    '27 to 52 then 1 to 26
        
        strFile = Dir(strPath & j & " week*")
        If strFile <> "" Then
            Workbooks.Open strPath & strFile
            Set Found = Range("B:B").Find(What:="GAS DRIVERS TOTAL", _
                                          LookIn:=xlFormulas, _
                                          LookAt:=xlWhole, _
                                          SearchOrder:=xlByRows, _
                                          SearchDirection:=xlNext, _
                                          MatchCase:=False)
            If Not Found Is Nothing Then
                NextRow = NextRow + 1
                Rows(Found.Row).Range("F1,R1,U1:W1,AE1").Copy _
                    Destination:=ws.Cells(NextRow, "A")
            Else
                'Row not found
            End If
            ActiveWorkbook.Close SaveChanges:=False
        Else
            'Week not found
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Weeks copied.", vbInformation, "Copy Complete"
    
End Sub

The above code was used to extract the data from the columns in the array, on the row where the text "Gas Driver" appeared on the worksheet "WEEK" of every workbook in the folder "P:\My Documents\Transport Figures\Year". Data was displayed on sheet 1 of a workbook with the code in a module. All files were similarly called but you may need to just refer to every workbook in folder

You should be able to adapt for your use by adjusting requirements, hop it gives some guidance

**lee_har** · 07-25-2017, 10:38 AM

Thanks for the quick response Nigelog.

I'll have a go with that later in the day.

**nigelog** · 07-25-2017, 10:58 AM

Sub ImportExcelfiles()
   Dim strPath As String
   Dim strFile As String
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim wsTarget As Worksheet
   Dim rowOutputTarget As Long
   
   strPath = " Q:\AX SYSTEM\Excel to AX via Schedule\count BOMs\"
   If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
   
   Set wsTarget = ThisWorkbook.Worksheets(1)
   
   rowOutputTarget = 2
   
   strFile = Dir(strPath & "*.xls*")
   
   Do Until strFile = ""
      
      'don't process the workbook containing this macro
      If strFile <> ThisWorkbook.Name Then
      
         Set wbSource = Workbooks.Open(strPath & strFile)
         Set wsSource = wbSource.Worksheets(“BOM”)
         
      
         wsSource.Range(“a2:b2”)Copy
         wsTarget.Range("A" & rowOutputTarget).PasteSpecial Paste:=xlPasteValues
      
         rowOutputTarget = rowOutputTarget + rowCountSource - 1
         
         wbSource.Close SaveChanges:=False
      End If
      strFile = Dir()
   Loop
   
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub

Hopefully this will work straight away from your workbook "Count cores"...

**nigelog** · 07-25-2017, 12:05 PM

tested....

Sub ImportExcelfiles()
   Dim strPath As String
   Dim strFile As String
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim wsTarget As Worksheet
   Dim rowOutputTarget As Long
   
   strPath = "Q:\AX SYSTEM\Excel to AX via Schedule\count BOMs\"
   If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
   
   Set wsTarget = ThisWorkbook.Worksheets("Sheet1")
   
   rowOutputTarget = 2
   
   strFile = Dir(strPath & "*.xls*")
   
   Do Until strFile = ""
      

      If strFile <> ThisWorkbook.Name Then
      
         Set wbSource = Workbooks.Open(strPath & strFile)

         Set wsSource = wbSource.Worksheets(1)
 
 
         wsSource.Range("a2:b2").Copy
         wsTarget.Range("A" & rowOutputTarget).PasteSpecial Paste:=xlPasteValues
      
         rowOutputTarget = rowOutputTarget + rowCountSource + 1
         
         wbSource.Close SaveChanges:=False
      End If
      strFile = Dir()
   Loop
   
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
MsgBox "All Done Here"
End Sub

Copy into This Workbook module and call from view macros after saving as .xlsm

**lee_har** · 07-25-2017, 02:37 PM

That's Great Nigelog. Works a treat with very minimal changes.

Thank you so much.

Lee

VBA to copy cell data from same worksheet in multiple workbooks within a folder.

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

VBA to copy cell data from same worksheet in multiple workbooks within a folder.

Re: VBA to copy cell data from same worksheet in multiple workbooks within a folder.

Re: VBA to copy cell data from same worksheet in multiple workbooks within a folder.

Re: VBA to copy cell data from same worksheet in multiple workbooks within a folder.

Re: VBA to copy cell data from same worksheet in multiple workbooks within a folder.

Re: VBA to copy cell data from same worksheet in multiple workbooks within a folder.

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Macro to copy data from multiple workbooks to one worksheet

VBA Merge Worksheet Content from Multiple Workbooks in a Folder into One Worksheet

Copy Active Worksheet into Multiple Workbooks in Separate Folder

Copy worksheet to multiple workbooks in a folder

copy & paste data from multiple workbooks to new workbook in a folder

VBA Copy Active worksheet to all workbooks in folder

Copy worksheet to all workbooks in specified folder

Bookmarks

Bookmarks

Posting Permissions