VBA code to copy paste from multiple workbook to one workbook

[kannan10]

Hello everyone,

I want to copy paste data from multiple workbook to single workbook. I have created sheet names Master Macro and in the sheet3 i have mentioned the names of the files(which is usually our employee names). VBA should go to the folder and fetch data from a sheet named "Rawdata" and should paste it in Master Macro workbook under sheet Rawdata. I have the below code and for some reason i keep getting a Compile error: For Without Next. I am relatively new and this code was given by one of my friend. Kindly help..

Here is the code:


Sub getLdata()

On Error Resume Next


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Sheets("Rawdata").Select
Range("A2:O20000").Select
Selection.ClearContents

For i = 1 To 5
Windows("Master Macro.xlsm").Activate
Sheets("Interface").Select

qname = Sheet3.Range("A" & 1 + i).Value

ChDir "M:\Production Sheet\2021\Dec 2021\"
Workbook.Open Filename:="M:\Production Sheet\2021\Dec 2021\" & quname & ".xlsm", ReadOnly:=True
UpdateLink = False

Application.Calculation = xlCalculationManual

Sheets("Rawdata").Select
Range("A2:O3000").Select
Selection.Copy
Windows("Master Macro.xlsm").Activate
Sheets("Rawdata").Select

testval = Range("A").Value
counter = 2
While testval <> ""
counter = counter + 1
testval = Range("A" & counter).Value
Wend
Range("A" & counter).Select
Selection.PasteSpecial
Paste = xlPasteValues
Operation = xlNone
Skipblanks = False
Transpose = False

Windows(qname & ".xlsm").Activate
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
Workbook(qname & ".xlsm").Close

Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

 

[Zot]

You have For i = 1 To 5 but not closed with Next
Not sure where you want to put your Next in the code.

 

[jolivanes]

Check all references and change as required.

Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
        pth = "C:\Folder One\Folder 2"    '<---- Change required
            For Each c In Sheets("Sheet3").Range("A1:A" & Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row)
                file_Open = Dir(pth & "\" & c.Value & ".xl*")
                    If Dir(pth & "\" & c.Value & ".xl*") <> "" Then
                        Workbooks.Open pth & "\" & file_Open
                            With ActiveWorkbook.Sheets("Rawdata")
                                .UsedRange.Copy ThisWorkbook.Sheets("Rawdata").Cells(ThisWorkbook.Sheets("Rawdata").Rows.Count, 1).End(xlUp).Offset(1)
                            End With
                        Workbooks(file_Open).Close False
                        file_Open = Dir
                    End If
            Next c
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
End Sub

 

[kannan10]

You have For i = 1 To 5 but not closed with Next
Not sure where you want to put your Next in the code.

Hello,

Thank you so much for the input. I shall try and see how it works.

Regards,
Kannan10

 

[kannan10]

Check all references and change as required.

Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
        pth = "C:\Folder One\Folder 2"    '<---- Change required
            For Each c In Sheets("Sheet3").Range("A1:A" & Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row)
                file_Open = Dir(pth & "\" & c.Value & ".xl*")
                    If Dir(pth & "\" & c.Value & ".xl*") <> "" Then
                        Workbooks.Open pth & "\" & file_Open
                            With ActiveWorkbook.Sheets("Rawdata")
                                .UsedRange.Copy ThisWorkbook.Sheets("Rawdata").Cells(ThisWorkbook.Sheets("Rawdata").Rows.Count, 1).End(xlUp).Offset(1)
                            End With
                        Workbooks(file_Open).Close False
                        file_Open = Dir
                    End If
            Next c
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
End Sub

Thank you for the quick revert. I tried running this code and got an error while running this code. Please check the screenshot...

 

[jolivanes]

I don't have a copy of your workbook but as I mentioned, check and change references where required.
Do you have a sheet named "Sheet3" in your Workbook?
Are the names of the files (workbooks) to be copied from in Column A starting at Cell A1?
Hover your mouse pointer over the yellow line and see where it says the culprit is

 

[kannan10]

I don't have a copy of your workbook but as I mentioned, check and change references where required.
Do you have a sheet named "Sheet3" in your Workbook?
Are the names of the files (workbooks) to be copied from in Column A starting at Cell A1?
Hover your mouse pointer over the yellow line and see where it says the culprit is

no the name of the sheet is "Names". Yes the files names to be copied from column A in sheets("Names")

I did the changes and it worked fine.

But i want one change in the code... i want the sheet to copy a particular range like range("A2:O2000"). I tried to add this range there and it is extracting data from a different sheet for some reason.

Below is the altered code i used. if you could help me with this minor correction, this should solve my problem.

Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
pth = "\\192.168.100.8\share\Production Sheet\2021\Dec 2021\"
For Each c In Sheets("Names").Range("A1:A" & Sheets("Names").Cells(Rows.Count, 1).End(xlUp).Row)
file_Open = Dir(pth & "\" & c.Value & ".xl*")
If Dir(pth & "\" & c.Value & ".xl*") <> "" Then
Workbooks.Open pth & "\" & file_Open
With ActiveWorkbook.Sheets("Rawdata")
.UsedRange.Copy.Copy ThisWorkbook.Sheets("Rawdata").Cells(ThisWorkbook.Sheets("Rawdata").Rows.Count, 1).End(xlUp).Offset(1)
End With
Workbooks(file_Open).Close False
file_Open = Dir
End If
Next c
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

 

[kannan10]

no the name of the sheet is "Names". Yes the files names to be copied from column A in sheets("Names")

I did the changes and it worked fine.

But i want one change in the code... i want the sheet to copy a particular range like range("A2:O2000"). I tried to add this range there and it is extracting data from a different sheet for some reason.

Below is the altered code i used. if you could help me with this minor correction, this should solve my problem.

Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
pth = "\\192.168.100.8\share\Production Sheet\2021\Dec 2021\"
For Each c In Sheets("Names").Range("A1:A" & Sheets("Names").Cells(Rows.Count, 1).End(xlUp).Row)
file_Open = Dir(pth & "\" & c.Value & ".xl*")
If Dir(pth & "\" & c.Value & ".xl*") <> "" Then
Workbooks.Open pth & "\" & file_Open
With ActiveWorkbook.Sheets("Rawdata")
.UsedRange.Copy.Copy ThisWorkbook.Sheets("Rawdata").Cells(ThisWorkbook.Sheets("Rawdata").Rows.Count, 1).End(xlUp).Offset(1)
End With
Workbooks(file_Open).Close False
file_Open = Dir
End If
Next c
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

Thank you once again. I figured it out... Now it is working absolutely fine.

thank you so much for your help.. This will save me and my team lot of production time.

 

[jolivanes]

You have a backslash where there should not be one (pth).

Why 2000 in A2:O2000?
Is that just so that you have enough?
Use a "LastRow" statement, something like

lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row    'One specific column
'or
lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row    'One specific column
'or
lr = Cells.Find("*", ,xlValues , , xlByRows, xlPrevious).Row     '= Values only, whole sheet
'or
lr = Cells.Find("*", ,xlFormulas , , xlByRows, xlPrevious).Row     '= Includes Formulas, whole sheet

Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
        pth = "C:\Folder One\Folder 2"    '<---- Change required
        If Not Right(pth, 1) = "\" Then pth = pth & "\"    '<---- Check for backslash
            For Each c In Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row)
                file_Open = Dir(pth & c.Value & ".xl*")
                    If Dir(pth & c.Value & ".xl*") <> "" Then
                        Workbooks.Open pth & file_Open
                            With ActiveWorkbook.Sheets(1)    '<---- Change required
                                .Range("A2:O2000").Copy ThisWorkbook.Sheets(3).Cells(ThisWorkbook.Sheets(3).Rows.Count, 1).End(xlUp).Offset(1)    '<---- Change required
                            End With
                        Workbooks(file_Open).Close False
                        file_Open = Dir
                    End If
            Next c
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
End Sub

Oh, and BTW

 

[kannan10]

You have a backslash where there should not be one (pth).

Why 2000 in A2:O2000?
Is that just so that you have enough?
Use a "LastRow" statement, something like

lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row    'One specific column
'or
lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row    'One specific column
'or
lr = Cells.Find("*", ,xlValues , , xlByRows, xlPrevious).Row     '= Values only, whole sheet
'or
lr = Cells.Find("*", ,xlFormulas , , xlByRows, xlPrevious).Row     '= Includes Formulas, whole sheet

Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
        pth = "C:\Folder One\Folder 2"    '<---- Change required
        If Not Right(pth, 1) = "\" Then pth = pth & "\"    '<---- Check for backslash
            For Each c In Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row)
                file_Open = Dir(pth & c.Value & ".xl*")
                    If Dir(pth & c.Value & ".xl*") <> "" Then
                        Workbooks.Open pth & file_Open
                            With ActiveWorkbook.Sheets(1)    '<---- Change required
                                .Range("A2:O2000").Copy ThisWorkbook.Sheets(3).Cells(ThisWorkbook.Sheets(3).Rows.Count, 1).End(xlUp).Offset(1)    '<---- Change required
                            End With
                        Workbooks(file_Open).Close False
                        file_Open = Dir
                    End If
            Next c
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
End Sub

Oh, and BTW

View attachment 53359

Thank you so much... Worked absolutely fine.. I am sure i will implement these logics in many of my reports.