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

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
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

C
  • Question Question
VBA code stuck (extract data from worksheet)
Replies
1
Views
393
Alex Blakenburg
A
J
  • Solved
Excel VBA to add file name to column C in worksheet
Replies
1
Views
620
mumps
mumps
Kristylee0228
  • Question Question
Populating Cell based on File Name and using a List
Replies
0
Views
414
Kristylee0228
Kristylee0228
E
  • Question Question
Macro to Pull Summary from Multiple Files
Replies
2
Views
510
dreid1011
dreid1011
D
  • Solved
Copying file path from a cell?
Replies
2
Views
386
Dave_george
D

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

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