Macro to copy data from multiple files into specific tabs in consolidated file

[Pyes]

Hi Everyone,

There's a piece of work I have to do on a monthly basis which can get quite repetitive. I have to copy the data from individual files and paste them in to different tabs in a master template. For example, we I have files called "Dept 0, Dept 1, Dept 2" etc and then the data from these files then have to go into the tab named "0, 1, 2" etc.

Is there a way that a macro can go through and copy the data from file Dept 0 and paste it into 0 and then go through each file in the specified folder and paste it into the tab? No formatting is needed on the data, it just needs to paste it into cell A1 in each tab.

I have been able to get a macro to copy data from multiple files all saved in one specific folder into one tab on the consolidated file, but I'm struggling to get the data to paste into the different tabs. All of the files will be saved in the same file so just selecting the folder to import will work well.

Any help is much appreciated.

Thanks,
Tom

 

[mumps]

Please use code tags to post your current macro.

 

[Pyes]

Hi,
Thanks for responding.
This is what I have for a similar process. This process convert the files saved down from .csv to .xlsx which isn't needed in the this process. However going into each .xlsx file in the selected folder and then copying into the different relevant tabs as I mentioned.

Public Sub DataCombine()

Dim stDPath As String
Dim wkbDFile As Workbook
Dim wksThisData As Worksheet
Dim x As Long
Dim rgCopy As Range
Dim lDEndRow As Long
Dim lOutRow As Long
Dim lRowCnt As Long
Dim vFolder As Variant
Dim lngCount As Long
Dim wksData As Worksheet
Dim vFile As Variant
    
    Dim xFd As FileDialog
    Dim xSPath As String
    Dim xCSVFile As String
    Dim xWsheet As String
    
    
Application.DisplayAlerts = False
Application.ScreenUpdating = False

    xWsheet = ActiveWorkbook.Name
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    xFd.Title = "Select a folder:"
    If xFd.Show = -1 Then
        xSPath = xFd.SelectedItems(1)
    Else
        Exit Sub
    End If
    If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
    xCSVFile = Dir(xSPath & "*.csv")
    Do While xCSVFile <> ""
        Application.StatusBar = "Converting: " & xCSVFile
        Workbooks.Open Filename:=xSPath & xCSVFile
        ActiveSheet.Name = "Data"
        ActiveWorkbook.SaveAs Replace(xSPath & xCSVFile, ".csv", ".xlsx", vbTextCompare), xlWorkbookDefault
        ActiveWorkbook.Close
        Windows(xWsheet).Activate
        xCSVFile = Dir
    Loop


'lOutRow = FindDataEnd(wsTgtSht) + 2
lOutRow = 1

ChDir xSPath

vFile = Dir(CurDir() & "\*.xlsx")

Do While vFile <> ""

    Set wkbDFile = Workbooks.Open(Filename:=vFile)
    Set wksData = wkbDFile.Sheets("Data")
    wksData.AutoFilterMode = False
    lDEndRow = FindDataEnd(wksData)
    Set rgCopy = Range(wksData.Cells(1, 1), wksData.Cells(lDEndRow, lEndCol))
    lRowCnt = rgCopy.Rows.Count
    
    rgCopy.Copy
    Data.Cells(lOutRow, 1).PasteSpecial Paste:=xlPasteFormulas
    Data.Cells(lOutRow, 1).PasteSpecial Paste:=xlPasteFormats
    
    lOutRow = lOutRow + lRowCnt
    
    wkbDFile.Close SaveChanges:=False
    
    'MsgBox CurDir() & "\" & vFile
     
    vFile = Dir()
    
Loop

End Sub

Any help would be really appreciated.
Thanks,
Tom

 

[mumps]

Try:

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, FolderName As String, tabName As String, val As String
    Set wkbDest = ThisWorkbook
    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
       .Show
       FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(FolderName & strExtension)
        val = Split(strExtension, " ")(1)
        tabName = Split(tabName, ".")(0)
        With wkbSource
            .Sheets("Data").UsedRange.Copy wkbDest.Sheets(tabName).Range("A1")
            .Close False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Pyes]

Hi,

Thanks for getting back to me.

It stopped at the point below:

The tab that the data will be put into isn't called "Data". That was from a previous macro which did something similar. The worksheet which the data needs to go into will change depending on which file has been picked up. If the file name needs to match the worksheet then this can be arranged.

Thanks,
Tom

 

[mumps]

Replace this line of code:

tabName = Split(tabName, ".")(0)

with this line:

tabName = Split(val, ".")(0)

The macro assumes that your file names use the following pattern:

xxxxx sheetname.xlsx

where the x's can be any character and "sheetname" is the name of the sheet. It also assumes that the file name has only one space in it. In my example, the space is between the last x and sheetname which follows the examples you posted in your original post. If your file names are not named in this way, please post 3 or four actual file names.

"Dept 0, Dept 1, Dept 2"

Also, the sheet "Data" is assumed to be the name of the source sheet not where the data will be pasted. It is also assumed that this name will be the same in all the source files. If this is not correct, what is the name of the source sheet?

 

[Pyes]

That's great, I'll make those changes now.

So the sheet names are "Department X Profit & Loss" where X is the different department number.

Would it be easier to write into the code to change the tab in each file to say "Data"?

 

[mumps]

Is the "Data" sheet in each file always the first sheet?

 

[Pyes]

Yes that's correct, it's the only sheet in the files

 

[mumps]

Try:

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, FolderName As String, tabName As String
    Set wkbDest = ThisWorkbook
    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
       .Show
       FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(FolderName & strExtension)
        tabName = Split(strExtension, " ")(1)
        With wkbSource
            .Sheets(1).UsedRange.Copy wkbDest.Sheets(tabName).Range("A1")
            .Close False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub