Macro to copy data from several worksheets into one

[fabian_andrew]

Hi Friends ,

I want to create a Macro that opens up several excel files and copy and paste the data into a single new file.

Example , I want to run the Macro from a Master File , It will then open each file in the folder and copy data from a sheet and paste into the master file.
Also it should append the data to next available row for every sheet it opens

 

[Joe4]

Try something like the following:

Sub MyCopy()

    Dim mwb As Workbook
    Dim nwb As Workbook
    Dim fldr As String
    Dim fname As String
    Dim mrow As Long
    
    Application.ScreenUpdating = False
    
'   Enter folder to get Excel files from
    fldr = "C:\Test\"
    
'   Capture this workbook as master workbook
    Set mwb = ActiveWorkbook
    
'   Loop through all Excel files (with "xlsx" extension) in specified folder
    fname = Dir(fldr & "*.xlsx")
    Do While fname <> ""
'       Open Excel file
        Set nwb = Workbooks.Open(fldr & fname)
'       Copy current region of Sheet1 of new file, starting in cell A1
        nwb.Sheets("Sheet1").Range("A1").CurrentRegion.Copy
'       Find next available row in column A of Sheet1 of master workbook
        mwb.Activate
        mrow = mwb.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row + 1
'       Paste data
        mwb.Sheets("Sheet1").Cells(mrow, "A").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
'       Close Excel file
        nwb.Close
'       Move to next file
        fname = Dir
    Loop

    Application.ScreenUpdating = True
    
End Sub

Note since you did not provide a lot of details, I had to make a bunch of assumptions, so you may need to change a few things in order for it to get to work for you.
However, the basic structure should be there. I added lots of documentation to show what each step is doing.

 

[Johnny C]

This is a good starting point.

You pick a folder, then look for files that match a certain name template.

You need for this to work :-
a worksheet named in vba - the name here is wksSupplier.

Then the following ranges defined in it.
"SuppSheetName" - the name of the sheet in files you open to copy data from
"SuppSheetFile" - a template name so if you wanted sheets called MyData1,Mydata2 etc. it would have the value MyData
"RowOne" - the first row you would want data pasting to in the target sheet

You may need to change the code to get it to work but it's a good starting point. This only plucks certain items out of the file, but it's not hard to tweak it to pick up ranges and copy and paste.

Sub ScanFiles()
Dim X
Dim strPath$, strFile$, strSuppName$, strThisFile$, strExt$, strTargetSheet$, strSuppFile$, strSuppID$
Dim strError$
Dim sglSuppAve!, intRedCount%, intRowCount%, intRowCountOriginal%
Dim wbTarget As Workbook, wbThisWB As Workbook
Dim FldrPicker As FileDialog


'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False

strThisFile = ActiveWorkbook.Name
strTargetSheet = wksSupplier.Range("SuppSheetName").Value
strSuppFile = wksSupplier.Range("SuppSheetFile").Value
intRowCount = wksSupplier.Range("RowOne").Value
intRowCountOriginal = wksSupplier.Range("RowOne").Value


'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        Application.AskToUpdateLinks = True
        MsgBox "No folder chosen"
        Exit Sub
    End If
    strPath = .SelectedItems(1) & "\"
End With
  
strPath = strPath
If strPath = "" Then
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    MsgBox "No folder chosen"
    Exit Sub
End If


'Target File Extension (must include wildcard "*")
strExt = strSuppFile & "*.xls*"
strFile = Dir(strPath & strExt)
Set wbThisWB = ActiveWorkbook

On Error Resume Next
wksSupplier.Range("Data").ClearContents
On Error GoTo 0

'Loop through each Excel file in folder
Do While strFile <> ""
    'Set variable equal to opened workbook
    If strFile <> strThisFile Then
        Set wbTarget = Workbooks.Open(Filename:=strPath & strFile)
        If UCase(Left(strFile, Len(strSuppFile))) = UCase(strSuppFile) Then
            strSuppID = Mid(strFile, Len(strSuppFile) + 1, InStrRev(strFile, ".") - Len(strSuppFile) - 1)
            'Ensure Workbook has opened before moving on to next line of code
            DoEvents
            
            'Get information from target workbook
            On Error Resume Next
            Sheets(strTargetSheet).Activate
            If Err.Number <> 0 Then
                On Error GoTo 0
                strSuppName = "Not known"
                sglSuppAve = 0
                intRedCount = 0
                strError = "Can't find sheet [" & strTargetSheet & "] in " & strFile
            Else:
                On Error GoTo 0
                strSuppName = Cells(2, 3).Value
                sglSuppAve = Cells(4, 3).Value
                intRedCount = Cells(6, 3).Value
                strError = ""
            End If
                    
            'Paste into this workbook
            wbThisWB.Activate
            Sheets("Summary").Activate
            
            Cells(intRowCount, 2).Value = strSuppName
            Cells(intRowCount, 3).Value = sglSuppAve
            Cells(intRowCount, 4).Value = intRedCount
            Cells(intRowCount, 5).Value = strError
            Application.ScreenUpdating = True
            DoEvents
            Application.ScreenUpdating = False
            intRowCount = intRowCount + 1
        End If
        'Save and Close Workbook
          wbTarget.Close SaveChanges:=False
          
        'Ensure Workbook has closed before moving on to next line of code
          DoEvents
    
        'Get next file name
    End If
    strFile = Dir
Loop

' If IntRowCount has incremented (i.e. 1 or more files found) then copy match formula down
If intRowCount <> intRowCountOriginal Then
    Range("MyFormula").Copy
    Range("PopulatedRows").Offset(0, -1).PasteSpecial (xlPasteFormulas)
End If

'reset system flags
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False

'Message Box when tasks are completed
If intRowCount <> intRowCountOriginal Then
    MsgBox "All done " & (intRowCount - wksSupplier.Range("RowOne").Value) & " files processed"
Else
    MsgBox "Could not find any files called 'Supplier '+supplier name in the folder you chose"
End If
Cells(wksSupplier.Range("RowOne").Value, 3).Select

End Sub

 

[fabian_andrew]

Thanks I got it to work