abhay_547
03-28-2019, 09:28 PM
I have this below macro which was built to copy data from one workbook excel sheet range to another workbook excel sheet range. Below is how it would work..
Files:
Workbook1: Macro File - this file consists of the names of the source workbooks, worksheet names in source workbook and data range which needs to be copied from those worksheet. It also consists of the same details of target workbook to paste the data
Workbook2: Source Data Workbook
Workbook3: Target Data workbook
Issue:Issue is in the line highlighted in RED in the below code .i.e. it just copies and pastes one cell of data from source workbook instead of entire range and copies the same one cell value into the entire range of the target workbook's worksheet range.
Sub 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
Files:
Workbook1: Macro File - this file consists of the names of the source workbooks, worksheet names in source workbook and data range which needs to be copied from those worksheet. It also consists of the same details of target workbook to paste the data
Workbook2: Source Data Workbook
Workbook3: Target Data workbook
Issue:Issue is in the line highlighted in RED in the below code .i.e. it just copies and pastes one cell of data from source workbook instead of entire range and copies the same one cell value into the entire range of the target workbook's worksheet range.
Sub 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