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]

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:

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:

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

 

[mumps]

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]

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

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]

Try (untested):

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]

Try (untested):

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!

 

[mumps]

You are very welcome.