Copy Data from Multiple Excel files to Mastefile

X

Xlacs

Board Regular
Joined
Mar 31, 2021
Messages
105
Office Version
  1. 2016
Platform
  1. Windows
I am currently novice when it comes to VBA and I have this problem that requires an expert in this field. So I have a Masterfile Named Archive with Extract button and I have multiple excel workbook (20+) in a folder. I wanted to copy a specific information from those workbook and paste it to my masterfile contionusly to the next blank cell.

Not sure what is not working, Hoping someone could actually assist me on this. =(

VBA Code: 
Sub loopthru()

Dim MyFile As String
Dim erow
Dim rw As Range

MyFile = Dir("C:\Users\ChrisLacs\Desktop\My Files\")


Do While Len(MyFile) > 0
If MyFile = "Archive.xlsm" Then
Exit Sub
End If

 If  rw.Columns("J").Value = "Apple" Then

Workbooks.Open (MyFile)
Range("B9:N9").Copy
ActiveWorkbook.Close


erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 13))

MyFile = Dir


Loop
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
You haven't assigned any object/value to rw and where you are using it in the line below it would probably be a worksheet not a range as you have declared it.

VBA Code: 
If  rw.Columns("J").Value = "Apple" Then
 
Upvote 0
My Bad. Actually, below is my actual code..

This Loop to all xlsm files in my folders and extract all the data. However, this only extract B9:N9 Data.
I wanted to extract Data from B:N data if my workbooks column J is equal to Apple..

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 = "B9:N9"
' 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
 
Upvote 0
First of all the code in post 3 doesn't resemble the code in post 1. I recommend in future posting your actual code from the start as it will save a lot of wasted time and frustration.

Try the code below. It assumes that when you stated
Xlacs said:
Data from B:N data if my workbooks column J is equal to Apple
Click to expand...
You mean from B2 until the last row. If you mean from B9 then change the red B1 in the code to B8.
It also assumes you have a header in J1 (or J8 if you are starting from B9).

I have left all the old code in there and just commented out the bits I didn't want

The code is untested so test it on a copy of your workbook

Rich (BB 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 = "B9:N9"
    ' 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
    
    '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

    fCount = 0
    
    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
            
                Set dCell = Sheet4.Cells(Sheet4.Rows.Count, dCol).End(xlUp).Offset(1)
            
                With sws.Range("B1:N" & sws.Range("B:N").Find("*", , xlValues, , xlByRows, xlPrevious).Row)
    
                    .AutoFilter 9, "Apple"
        
                    On Error Resume Next
                    .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Copy dCell
                    On Error GoTo 0
                    
                    fCount = Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) - 1 + fCount
                    
                    .AutoFilter
                    
                End With
            
            
            
                ' 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
                
            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
 
Upvote 0
MARK858 said:
First of all the code in post 3 doesn't resemble the code in post 1. I recommend in future posting your actual code from the start as it will save a lot of wasted time and frustration.

Try the code below. It assumes that when you stated

You mean from B2 until the last row. If you mean from B9 then change the red B1 in the code to B8.
It also assumes you have a header in J1 (or J8 if you are starting from B9).

I have left all the old code in there and just commented out the bits I didn't want

The code is untested so test it on a copy of your workbook

Rich (BB 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 = "B9:N9"
    ' 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
   
    '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

    fCount = 0
   
    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
           
                Set dCell = Sheet4.Cells(Sheet4.Rows.Count, dCol).End(xlUp).Offset(1)
           
                With sws.Range("B1:N" & sws.Range("B:N").Find("*", , xlValues, , xlByRows, xlPrevious).Row)
   
                    .AutoFilter 9, "Apple"
       
                    On Error Resume Next
                    .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Copy dCell
                    On Error GoTo 0
                   
                    fCount = Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) - 1 + fCount
                   
                    .AutoFilter
                   
                End With
           
           
           
                ' 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
               
            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
Click to expand...
MARK858 said:
First of all the code in post 3 doesn't resemble the code in post 1. I recommend in future posting your actual code from the start as it will save a lot of wasted time and frustration.

Try the code below. It assumes that when you stated

You mean from B2 until the last row. If you mean from B9 then change the red B1 in the code to B8.
It also assumes you have a header in J1 (or J8 if you are starting from B9).

I have left all the old code in there and just commented out the bits I didn't want

The code is untested so test it on a copy of your workbook

Rich (BB 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 = "B9:N9"
    ' 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
   
    '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

    fCount = 0
   
    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
           
                Set dCell = Sheet4.Cells(Sheet4.Rows.Count, dCol).End(xlUp).Offset(1)
           
                With sws.Range("B1:N" & sws.Range("B:N").Find("*", , xlValues, , xlByRows, xlPrevious).Row)
   
                    .AutoFilter 9, "Apple"
       
                    On Error Resume Next
                    .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Copy dCell
                    On Error GoTo 0
                   
                    fCount = Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) - 1 + fCount
                   
                    .AutoFilter
                   
                End With
           
           
           
                ' 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
               
            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
Click to expand...

Hi There,

First, Thank you for noticing my post..

Im actually having a hard time explaining my issues..

Just to give you an idea.

I have uploaded my Archive masterfile and two of mmy workbooks.



Basically, I just wanted to filter the dates, like for example, in my archive workbook, if I type 21may in cell A1. all my workbooks will be filtered to May21 and paste it to my masterfile.. Just dunno where to start.. pew
 
Upvote 0
I would suggest starting a new post, explaining exactly what you want with examples of your data (you'll get more people looking at it if you use the boards XL2BB tool for this, as a lot of members won't download files).

They will also need to know if they are real dates and if what you are typing in is a real date or text
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Add a code or number at the end of the file name using VBA (Looped)
Replies
3
Views
122
HighAndWilder
H
R
  • Question Question
VBA Generate email with multiple data in body.
Replies
2
Views
131
Logit
Logit
D
  • Question Question
Importing data from another spreadsheet as a value
Replies
1
Views
86
Eric W
Eric W
C
  • Question Question
VBA code stuck (extract data from worksheet)
Replies
1
Views
411
Alex Blakenburg
A
J
  • Solved
Excel VBA to add file name to column C in worksheet
Replies
1
Views
664
mumps
mumps

Forum statistics

Threads
1,224,823
Messages
6,181,179
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top