Public strFileName As String
Public currentWB As Workbook
Public dataWB As Worksheet
Sub GetData2()
Dim strListSheet As String
Dim r As Range, l As Long, lrng As Range
Application.ScreenUpdating = False
strListSheet = "List"
With Sheets(strListSheet)
l = .Cells(.Rows.Count, 2).End(xlUp).Row
Set lrng = .Range("B2:B" & l)
End With
Set currentWB = ThisWorkbook
For Each r In lrng
strFileName = r.Offset(0, 1).Value & r.Value
strWhereToCopy = r.Offset(0, 4).Value
On Error GoTo ErrH
Application.Workbooks.Open strFileName ', UpdateLinks:=False, ReadOnly:=True
Set dataWB = ActiveSheet
dataWB.UsedRange.Copy
With currentWB.Sheets(strWhereToCopy)
lastRow = .UsedRange.Rows.Count
.Cells(lastRow + 1, 1).PasteSpecial xlPasteValues ', xlPasteSpecialOperationNone
End With
Application.CutCopyMode = False
dataWB.Parent.Close False
currentWB.Save
Next
Application.ScreenUpdating = True
Set dataWB = Nothing
Set lrng = Nothing
Exit Sub
ErrH:
MsgBox "It seems some file was missing. The data copy operation is not complete.", vbCritical, "File Missing"
End Sub
Public strFileName As String
Public currentWB As Workbook
Public dataWB As Worksheet
Sub GetData4()
Dim strListSheet As String
Dim r As Range, l As Long, lrng As Range, lastRow As Long
Dim lr As Long, copyrng As Range
Application.ScreenUpdating = False
strListSheet = "List"
With Sheets(strListSheet)
l = .Cells(.Rows.Count, 2).End(xlUp).Row
Set lrng = .Range("B2:B" & l)
End With
Set currentWB = ThisWorkbook
For Each r In lrng
strFileName = r.Offset(0, 1).Value & r.Value
strWhereToCopy = r.Offset(0, 4).Value
On Error GoTo ErrH
Application.Workbooks.Open strFileName ', UpdateLinks:=False, ReadOnly:=True
Set dataWB = ActiveSheet
Set copyrng = dataWB.UsedRange
copyrng.Copy
With currentWB.Sheets(strWhereToCopy)
lastRow = .UsedRange.Rows.Count
.Cells(lastRow + 1, 3).PasteSpecial xlPasteValues ', xlPasteSpecialOperationNone
.Range("A" & lastRow + 1 & ":A" & copyrng.Rows.Count + lastRow) = _
Right(strFileName, Len(strFileName) - InStrRev(strFileName, "\")) 'strFileName
.Range("B" & lastRow + 1 & ":B" & copyrng.Rows.Count + lastRow) = dataWB.Name
End With
Application.CutCopyMode = False
With currentWB.Sheets("Status")
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lr + 1, 1) = lr
.Cells(lr + 1, 2) = strFileName 'dataWB.Parent.FullName
.Cells(lr + 1, 3) = FileDateTime(strFileName)
.Cells(lr + 1, 4) = dataWB.Name
.Cells(lr + 1, 5) = copyrng.Address
.Cells(lr + 1, 6) = Cells(lastRow + 1, 1).Address
.Cells(lr + 1, 7) = Now
.Cells(lr + 1, 8) = "YES"
i = i + 1
End With
'Sheets("Status").Range("H3:H" & lr + 1).Replace "", "NO"
Application.CutCopyMode = False
dataWB.Parent.Close False
currentWB.Save
Next
Application.ScreenUpdating = True
Set dataWB = Nothing
Set lrng = Nothing
Exit Sub
ErrH:
MsgBox "It seems some file was missing. The data copy operation is not complete.", vbCritical, "File Missing"
Sheets("Status").Range("H2:H" & lr + 1).Replace "", "NO"
End Sub
You might not loop in the macro as it will copy data of usedcell instead of define range. if u wish for the same then pls check with all point of view & let me know so that i will do the final changes in the same.This macro not work proper when i give different range to copy paste then macro copy A1:J10 data only
Set copyrng = dataWB.UsedRange this line is in code & i want what ever mention the data range i want pull that data only is it possible All sheets from given file to pull or Specify sheet name pull the data
Set copyrng = Range(r.Offset(0, 2).Value & ":" & r.Offset(0, 3).Value)
On Error GoTo ErrH
Application.Workbooks.Open strFileName ', UpdateLinks:=False, ReadOnly:=True
Set dataWB = ActiveSheet
'Set copyrng = dataWB.UsedRange
Range(copyrng.Address).Copy
Deepak can u upload the file
Don't forget to like to encourage us.Thanks for ur support this is work fine
Welcome dear.....Thanks Alot Deepak Thanks for your G8 Support