Copy & paste rows from a fixed range from multiple workbooks stored in a folder into a separate workbook ONLY if a column contains specific text.

chappy

New Member
Joined
Jul 18, 2006
Messages
29
I am consolidating data from multiple workbooks into another workbook "Consolidation". All the files are stored in the same folder. The names of the workbooks may change and the number of workbooks may increase or decrease. The worksheet name "Key_metrics" and the data range "B5:BZ64" to copy from is fixed.

I am able to do this so that the macro copies the data in the data range "B5:BZ64" from each of the sheets named "Key_metrics" in all of the workbooks in the folder and pastes into "Consolidation" workbook on the "Consol" worksheet.

However not all of the rows in the data range "B5:BZ64" are required. I only need to copy across rows which have the text "Yes" in column "E" of the "Key_metrics" worksheets. Is there a way to only copy across rows within the date "B5:BZ64" if column "E" = "Yes"?

I know that it is possible to add a filter with criteria <> "Yes" for the column and delete those rows after the full data range has been transferred. However, I have named ranges in the file and if I filter and delete after the data is transferred the named ranges change as rows are deleted.

If anyone can help it would be amazing. Below is the code I am using for the full data transfer:

VBA Code:
Sub Consol()

Dim fPath As String
Dim fName As String
Dim wb As Workbook
Dim sh As Worksheet

Set sh = Workbooks("Consolidation.xlsm").Sheets("Consol")

Application.ScreenUpdating = False

fPath = "W:\ConisioNOR\Finance Shared\Planning & Forecasting\2020_Asset_Planning\03_2020_ALR\ALR QVM\"
fName = Dir(fPath & "*.xls*")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
                On Error Resume Next
                    If Not Sheets("Key_metrics") Is Nothing Then
                        Sheets("Key_metrics").Range("B5:BZ64").Copy
                        sh.Cells("B5:B5").Select
                        sh.Cells(Rows.Count, 2).End(xlUp).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                 Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End If
                On Error GoTo 0
                Err.Clear
                wb.Close False
        End If
        fName = Dir
    Loop

Application.ScreenUpdating = True

MsgBox "Data transfer complete"

End Sub


This is the filter & delete code I am using which I would like to replace by only pasting the data with "Yes" in the column:

VBA Code:
Sub Delete_non_opportunities()

Dim ws As Worksheet

  'Set reference to the sheet in the workbook.
  Set ws = ThisWorkbook.Worksheets("Consol")
  ws.Activate 'not required but allows user to view sheet if warning message appears
  
  'Clear any existing filters
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0

  '1. Apply Filter
  ws.Range("B5:BZ1500").AutoFilter Field:=4, Criteria1:="No"
  
  '2. Delete Rows
  Application.DisplayAlerts = False
    ws.Range("B5:BZ1500").SpecialCells(xlCellTypeVisible).Delete
  Application.DisplayAlerts = True
  
  '3. Clear Filter
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0


End Sub
 

Some videos you may like

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,238
You actually don't need two macros and you don't have to delete any data. In the first macro filter on "Yes" and then copy only the visible cells to the Consul sheet.
 

chappy

New Member
Joined
Jul 18, 2006
Messages
29
You actually don't need two macros and you don't have to delete any data. In the first macro filter on "Yes" and then copy only the visible cells to the Consul sheet.

Thanks for your reply mumps! Great idea! Only problem is I can't seem to make it happen. Below is my attempt. It copies the data across but it still copies data including the "No" rows. If you could suggest tweaks or corrections it would be much appreciated!

Thanks

VBA Code:
Sub Consol()
Dim fPath As String
Dim fName As String
Dim wb As Workbook
Dim sh As Worksheet

Set sh = Workbooks("Consolidation.xlsm").Sheets("Consol")
Application.ScreenUpdating = False
fPath = "W:\ConisioNOR\Finance Shared\Planning & Forecasting\2020_Asset_Planning\03_2020_ALR\ALR QVM\"
fName = Dir(fPath & "*.xls*")
Do While fName <> ""
If fName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(fPath & fName)
On Error Resume Next
If Not Sheets("Key_metrics") Is Nothing Then
Sheets("Key_metrics").Range("B5:BZ1500").AutoFilter Field:=4, Criteria1:="No"
Sheets("Key_metrics").Range("B5:BZ64").Copy
sh.Cells("B5:B5").Select
sh.Cells(Rows.Count, 2).End(xlUp).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
On Error GoTo 0
Err.Clear
wb.Close False
End If
fName = Dir
    Loop

Application.ScreenUpdating = True
MsgBox "Data transfer complete"
End Sub
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,238
Try (untested):
VBA Code:
Sub Consol()
    Dim fPath As String, fName As String, wb As Workbook, sh As Worksheet
    Set sh = Workbooks("Consolidation.xlsm").Sheets("Consol")
    Application.ScreenUpdating = False
    fPath = "W:\ConisioNOR\Finance Shared\Planning & Forecasting\2020_Asset_Planning\03_2020_ALR\ALR QVM\"
    fName = Dir(fPath & "*.xls*")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
            If Evaluate("isref('Key_metrics'!A1)") Then
                With Sheets("Key_metrics")
                    .Range("B5:BZ1500").AutoFilter Field:=4, Criteria1:="Yes"
                    .Range("B5:BZ64").SpecialCells(xlCellTypeVisible).Copy
                    sh.Cells(sh.Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                    If .FilterMode Then .ShowAllData
                End With
            End If
            wb.Close False
        End If
        fName = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "Data transfer complete"
End Sub
 

chappy

New Member
Joined
Jul 18, 2006
Messages
29
Try (untested):
VBA Code:
Sub Consol()
    Dim fPath As String, fName As String, wb As Workbook, sh As Worksheet
    Set sh = Workbooks("Consolidation.xlsm").Sheets("Consol")
    Application.ScreenUpdating = False
    fPath = "W:\ConisioNOR\Finance Shared\Planning & Forecasting\2020_Asset_Planning\03_2020_ALR\ALR QVM\"
    fName = Dir(fPath & "*.xls*")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
            If Evaluate("isref('Key_metrics'!A1)") Then
                With Sheets("Key_metrics")
                    .Range("B5:BZ1500").AutoFilter Field:=4, Criteria1:="Yes"
                    .Range("B5:BZ64").SpecialCells(xlCellTypeVisible).Copy
                    sh.Cells(sh.Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                    If .FilterMode Then .ShowAllData
                End With
            End If
            wb.Close False
        End If
        fName = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "Data transfer complete"
End Sub


Hi mumps. Thanks that worked perfectly! Thanks for your help!
 

Watch MrExcel Video

Forum statistics

Threads
1,126,970
Messages
5,621,889
Members
415,864
Latest member
cybid

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
Top