copy data from multiple workbook ranges into one workbook sheet ranges

[abhay_547]

I have requirement to copy a range of data from multiple workbooks into one workbook, but the ask is not to save the macro in either of the workbooks. So i need a third file which would have the names of the files listed in Cell A4 to A12 (can be more files as well). Cell A2 would consist the date when I select the date the names of the workbooks which are listed in cell A4 to A12 will get updated since they all would have date in their names, once the names are updated I would run the macro which would first open the main template workbook, the name of which would be in Cell B2 and it's path is in C1 and then open each file in loop from cell A4 to A12 and copy the data from the range which is mentioned in the cell C4 to C12 from each source file and paste it into the template file range mentioned in column D4 to D12, for each file the path would be different so the path will be mentioned in Column B .i.e. B4 to B12. Incase the current date file is not available on the path then column E4 to E12 would get populated with text "File not available", if available and the data is copied then "File Available. Data Copied"


Attached is the sample structure of the file.


Below is the code which I have so far.



Sub WorkbookLoop() Dim i As Integer
Dim finalRow As Integer

finalRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 4 To finalRow
'Workbook open, range copy, range paste, close workbook.
Workbooks.Open Filename:= "c:\desktop\folder A\A_21_11_2017.xlsx" ' workbook name is hardcoded, i want this to be referring to the cell value
Range("H7:H11").Select ' range hardcoded, i want this to be referring to the cell value
Selection.Copy
Windows("Template").Activate ' workbook name is hardcoded, i want this to be referring to the cell value
Range("G7:G11").Select 'range hardcoded, i want this to be referring to the cell value
ActiveSheet.Paste
Windows("A_21_11_2017.xlsx").Activate ' workbook name is hardcoded, i want this to be referring to the cell value
ActiveWindow.Close
Windows("Template").Activate ' workbook name is hardcoded, i want this to be referring to the cell value

Next i
End Sub




Also i want the workbook availability status to be updated in the column E if the workbook is not available.

[abhay_547]

Can anyone help with the above code

[mike7952]

Untested but should give you the general idea. Just modified your code for your needs.


Sub WorkbookLoop()
Dim sFileName As String
Dim sFilePath As String
Dim sCopyRange As String
Dim sPasteRange As String
Dim sTemplateFile As String
Dim sTemplatePath As String
Dim arr As Variant

Dim i As Integer
Dim finalRow As Integer

finalRow = Cells(Rows.Count, 1).End(xlUp).Row
sTemplateFile = Cells(2, "B").Value
sTemplatePath = Cells(2, "C").Value
For i = 4 To finalRow
With ThisWorkbook.Worksheets("Sheet1")
sFileName = .Cells(i, "A").Value
sFilePath = .Cells(i, "B").Value
sCopyRange = .Cells(i, "C").Value
sPasteRange = .Cells(i, "D").Value
End With
'Workbook open, range copy, range paste, close workbook.
Workbooks.Open Filename:=sFilePath & "\" & sFileName 'workbook name is hardcoded, i want this to be referring to the cell value
Range(sCopyRange).Select ' range hardcoded, i want this to be referring to the cell value
Selection.Copy
Windows(sTemplateFile).Activate ' workbook name is hardcoded, i want this to be referring to the cell value
Range(sPasteRange).Select 'range hardcoded, i want this to be referring to the cell value
ActiveSheet.Paste
Windows(sFileName).Activate ' workbook name is hardcoded, i want this to be referring to the cell value
ActiveWindow.Close
Windows(sTemplateFile).Activate ' workbook name is hardcoded, i want this to be referring to the cell value

Next i
End Sub

[abhay_547]

Untested but should give you the general idea. Just modified your code for your needs.


Sub WorkbookLoop()
Dim sFileName As String
Dim sFilePath As String
Dim sSrcwsht As String
Dim sCopyRange As String
Dim sTgtwsht As String
Dim sPasteRange As String
Dim sTemplateFile As String
Dim sTemplatePath As String
Dim arr As Variant

Dim i As Integer
Dim finalRow As Integer

finalRow = Cells(Rows.Count, 1).End(xlUp).Row
sTemplateFile = Cells(1, "B").Value
sTemplatePath = Cells(1, "C").Value
For i = 4 To finalRow
With ThisWorkbook.Worksheets("Sheet1")
sFileName = .Cells(i, "A").Value
sFilePath = .Cells(i, "B").Value
sSrcwsht = .Cells(i, "C").Value
sCopyRange = .Cells(i, "D").Value
sTgtwsht = .Cells(i, "E").Value
sPasteRange = .Cells(i, "F").Value
End With
'Workbook open, range copy, range paste, close workbook.
Workbooks.Open Filename:=sFilePath & "\" & sFileName 'workbook name is hardcoded, i want this to be referring to the cell value
Range(sCopyRange).Select ' range hardcoded, i want this to be referring to the cell value
Selection.Copy
Windows(sTemplateFile).Activate ' workbook name is hardcoded, i want this to be referring to the cell value
Range(sPasteRange).PasteSpecial xlPasteValues 'range hardcoded, i want this to be referring to the cell value
Application.CutCopyMode = False
On Error Resume Next
Windows(sFileName).Activate ' workbook name is hardcoded, i want this to be referring to the cell value
ActiveWindow.Close
Windows(sTemplateFile).Activate ' workbook name is hardcoded, i want this to be referring to the cell value

Next i
End Sub


I have made few more changes .i.e. included the source worksheet and target worksheet name columns and have given the reference to the same in the above code but i still need help on the below.

1) In column G I want to update the status of the file availability, if the file is available in the folder the it should update the text in the column G row cell as "File available. Date Copied
" and if the file is not available then it should get populated with text "File not available" in each row against each file
2) If multiple ranges need to be copied from the same file then it shouldn't open, copy and close the file multiple times, it should open it once copy all ranges and paste all ranges and then close the workbook.
3) On Error Resume next file update column G and resume next file, same as 1st point

[abhay_547]

Can anyone help with the above code

[abhay_547]

Can anyone help with the above code


Can anyone help with the above code

[abhay_547]

Can anyone help with the above code



Can anyone help with the above code

[mancubus]

with this type of struct, you should not mind multiple openings of the same file.

setting ScreenUpdating to False will help you bear with it. :devil2:

it seems you are not experienced in vba, so i will not offer an array solution.




Sub vbax_61399_copy_data_from_multiple_wb()

Dim tmp_wb As Workbook, source_wb As Workbook
Dim LastRow As Long, i As Long, calc As Long
Dim fName As String, fPath As String
Dim CopyWS As String, CopyRng As String
Dim PasteWS As String, PasteRng As String

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
calc = .Calculation
.Calculation = xlCalculationManual
End With

With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row

On Error Resume Next
Set tmp_wb = Workbooks(.Range("C2").Value & .Range("B2").Value)
If Err Then
Err.Clear
Set tmp_wb = Workbooks.Open(.Range("C2").Value & .Range("B2").Value)
End If
On Error GoTo 0

For i = 4 To LastRow
fName = .Range("A" & i).Value
fPath = .Range("B" & i).Value
CopyWS = .Range("C" & i).Value
CopyRng = .Range("D" & i).Value
PasteWS = .Range("E" & i).Value
PasteRng = .Range("F" & i).Value
If Dir(fPath & fName) <> "" Then 'file exists
Set source_wb = Workbooks.Open(fPath & fName)
tmp_wb.Worksheets(PasteWS).Range(PasteRng).Value = source_wb.Worksheets(CopyWS).Range(CopyRng).Value
.Range("G" & i).Value = "File Available. Data Copied"
Else 'file does not exist
.Range("G" & i).Value = "File Not Available"
End If

source_wb.Close False
Next
End With

With Application
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = calc
.StatusBar = False
End With

End Sub

[abhay_547]

with this type of struct, you should not mind multiple openings of the same file.

setting ScreenUpdating to False will help you bear with it. :devil2:

it seems you are not experienced in vba, so i will not offer an array solution.




Sub vbax_61399_copy_data_from_multiple_wb()

Dim tmp_wb As Workbook, source_wb As Workbook
Dim LastRow As Long, i As Long, calc As Long
Dim fName As String, fPath As String
Dim CopyWS As String, CopyRng As String
Dim PasteWS As String, PasteRng As String

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
calc = .Calculation
.Calculation = xlCalculationManual
End With

With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row

On Error Resume Next
Set tmp_wb = Workbooks(.Range("C2").Value & .Range("B2").Value)
If Err Then
Err.Clear
Set tmp_wb = Workbooks.Open(.Range("C2").Value & .Range("B2").Value)
End If
On Error GoTo 0

For i = 4 To LastRow
fName = .Range("A" & i).Value
fPath = .Range("B" & i).Value
CopyWS = .Range("C" & i).Value
CopyRng = .Range("D" & i).Value
PasteWS = .Range("E" & i).Value
PasteRng = .Range("F" & i).Value
If Dir(fPath & fName) <> "" Then 'file exists
Set source_wb = Workbooks.Open(fPath & fName)
tmp_wb.Worksheets(PasteWS).Range(PasteRng).Value = source_wb.Worksheets(CopyWS).Range(CopyRng).Value
.Range("G" & i).Value = "File Available. Data Copied"
Else 'file does not exist
.Range("G" & i).Value = "File Not Available"
End If

source_wb.Close False
Next
End With

With Application
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = calc
.StatusBar = False
End With

End Sub




I have made changes to the references as per my workbook (see the text in bold)


Sub vbax_61399_copy_data_from_multiple_wb()
Dim tmp_wb As Workbook, source_wb As Workbook
Dim LastRow As Long, i As Long, calc As Long
Dim fName As String, fPath As String
Dim CopyWS As String, CopyRng As String
Dim PasteWS As String, PasteRng As String

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
calc = .Calculation
.Calculation = xlCalculationManual
End With

With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row

On Error Resume Next
Set tmp_wb = Workbooks(.Range("F1").Value & .Range("D1").Value)
If Err Then
Err.Clear
Set tmp_wb = Workbooks.Open(.Range("F1").Value & .Range("D1").Value)
End If
On Error GoTo 0

For i = 4 To LastRow
fName = .Range("A" & i).Value
fPath = .Range("B" & i).Value
CopyWS = .Range("C" & i).Value
CopyRng = .Range("D" & i).Value
PasteWS = .Range("E" & i).Value
PasteRng = .Range("F" & i).Value
If Dir(fPath & fName) <> "" Then 'file exists
Set source_wb = Workbooks.Open(fPath & fName)
tmp_wb.Worksheets(PasteWS).Range(PasteRng).Value = source_wb.Worksheets(CopyWS).Range(CopyRng).Value
.Range("G" & i).Value = "File Available. Data Copied"
Else 'file does not exist
.Range("G" & i).Value = "File Not Available"
End If
On Error Resume Next
Workbooks(source_wb).Close
Next
End With

With Application
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = calc
.StatusBar = False
End With

End Sub




Actually column G wouldn't have the status of the unavailable files already updated, it will be completely blank when you start running the macro, if the macro doesn't find the source file which is mentioned in column A, on the path which is mentioned in column B then instead of showing error, it populates "File Not Available" text in the column G for that row and moves to the next row. We wouldn't know if the files are available for the day since multiple users are savings those files in multiple shared paths hence instead of opening each folder and checking, the macro checks it .i.e. if it's unable to find the file when trying to open then instead of showing error it simply populates the column G with "File not available". Now I am aware that this could happen even if the naming convention of the source file is slightly different from what is mentioned in the macro file column A but that will be taken care by user who is saving the source file as he will be asked to stick to the standard naming convention with no changes to be saved daily on the listed path.


for e.g. once the macro is executed and we see that for 5 files the column G was populated with the text "File Not Available" and the file is actually not available since the user who is owning that file hasn't saved it on the path for that day, after an hour or so, the user confirms that the 5 files are now saved on the respective paths and now when rerun the macro it will copy paste the data from all the files instead of copying it from only on those file files..in order to take care of this can we incorporate something like below condition in the code to check before running the script.


If ThisWorkbook.Sheets(1).Range("G" & i) <> "File Available. Data Copied" Then