Hi Good People,
To make it short, so I have this Masterfile called Archive with extraction button and I have multiple workbooks (20+).
In my Masterfile A1 field when I typed a particular date. (e.g. A1 = 21-May) and click Run. All my my workbooks(20+) will be filtered and copy all the data to my mastefile next available cell.
But I am nowhere near of that possibility. Hoping someone could actually assist me on doing this.. =(
To make it short, so I have this Masterfile called Archive with extraction button and I have multiple workbooks (20+).
In my Masterfile A1 field when I typed a particular date. (e.g. A1 = 21-May) and click Run. All my my workbooks(20+) will be filtered and copy all the data to my mastefile next available cell.
But I am nowhere near of that possibility. Hoping someone could actually assist me on doing this.. =(
VBA Code:
Sub CopyRows()
' Source
Const sFolderPath As String = "C:\Users\ChrisLacs\Desktop\My Files\"
Const sFilePattern As String = "*.xlsm*"
Const sName As String = "Sheet1"
Const sAddress As String = "B200:N200"
' Destination
Const dCol As String = "B"
Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
If Len(sFileName) = 0 Then
MsgBox "No files matching the pattern '" & sFilePattern _
& "'" & vbLf & "found in '" & sFolderPath & "'.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = Sheet4.Parent
Dim dFileName As String: dFileName = dwb.Name
Dim dCell As Range
Set dCell = Sheet4.Cells(Sheet4.Rows.Count, dCol).End(xlUp).Offset(1)
Dim drg As Range
Set drg = dCell.Resize(, Sheet4.Range(sAddress).Columns.Count)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim fCount As Long
Do Until Len(sFileName) = 0
If StrComp(sFileName, dFileName, vbTextCompare) <> 0 Then
Set swb = Workbooks.Open(sFolderPath & sFileName)
On Error Resume Next ' attenpt to reference the source worksheet
Set sws = swb.Worksheets(sName)
On Error GoTo 0
If Not sws Is Nothing Then ' source worksheet found
Set srg = sws.Range(sAddress)
' Either copy values, formulas, formats...
srg.Copy drg
' ... or instead copy only values (more efficient (faster))
'drg.Value = srg.Value
Set drg = drg.Offset(1)
Set sws = Nothing
fCount = fCount + 1
'Else ' source worksheet not found; do nothing
End If
swb.Close SaveChanges:=False
End If
sFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Rows copied: " & fCount, vbInformation
End Sub