Tweak Macro that Imports specific table columns from a different workbook to filter a column first

[sspatriots]

Hi,

I have this macro that I pieced together this morning from another macro. Basically, it temporarily opens another workbook and copies 4 different ranges of table columns back into back into a different table on my destination workbook where the macro resides. The last column defined in "My_Range1" is called "Job Status" (with a carriage return after Job, hence the use of "Chr(10)" in between). Anyhow, I would like to know if it is possible to filter that whole source worksheet for two values in that "Job Status" column prior to bringing the column information into the destination workbook. The values would be "0 NEW" and "1 ACT". Any assistance on this would be greatly appreciated. Thanks, SS

Sub Refresh_n_ResizePOJobListTable()

Dim wb1, wb2 As Workbook
Dim file_path1 As String
Dim ws1, ws2, ws3, ws4 As Worksheet
Dim rng1 As Range
Dim My_Range1, My_Range2, My_Range3, My_Range4 As Range
Dim tb1 As ListObject
Dim LastRow1 As Long
Dim BlankCount As Long


With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .CutCopyMode = False
    .DisplayAlerts = True
    .Calculation = xlCalculationManual
End With


Set wb1 = ThisWorkbook

file_path1 = "H:\Jobs\00 ENGINEERING DATA\SPS Job List, 022924.xlsm"      'Path to Job List.xlsm
Set wb2 = Workbooks.Open(Filename:=file_path1, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)     'Job List.xlsm

Set ws1 = wb1.Worksheets("PO Job List")
Set ws2 = wb2.Worksheets("Jobs")

Set tbl = ws1.ListObjects("tblG2JobList")

Set My_Range1 = ws2.Range("G2JobList[[#Data],[Record]:[Job" & Chr(10) & "Status]]")
Set My_Range2 = ws2.Range("G2JobList[[#Data],[G1" & Chr(10) & "Status]:[G1" & Chr(10) & "APPD Date]]")
Set My_Range3 = ws2.Range("G2JobList[[#Data],[G1 MFG" & Chr(10) & "SCHED" & Chr(10) & "Due Date]:[G1" & Chr(10) & "COMPL Date]]")
Set My_Range4 = ws2.Range("G2JobList[[#Data],[Jack" & Chr(10) & "Vendor]:[Wiring" & Chr(10) & "SHPG ARR/" & Chr(10) & "ITEM LCTN]]")

LastRow1 = ws2.Range("G2JobList[#All]").SpecialCells(xlCellTypeLastCell).Row - 1
Set rng1 = ws1.Range("tblG2JobList[#All]").Resize(LastRow1)
tbl.Resize rng1

ws1.Range("tblG2JobList[[#Data],[Record]:[Job" & Chr(10) & "Status]]").Value2 = My_Range1.Value2
ws1.Range("tblG2JobList[[#Data],[G1" & Chr(10) & "Status]:[G1" & Chr(10) & "APPD Date]]").Value2 = My_Range2.Value2
ws1.Range("tblG2JobList[[#Data],[G1 MFG" & Chr(10) & "SCHED" & Chr(10) & "Due Date]:[G1" & Chr(10) & "COMPL Date]]").Value2 = My_Range3.Value2
ws1.Range("tblG2JobList[[#Data],[Jack" & Chr(10) & "Vendor]:[Wiring" & Chr(10) & "SHPG ARR/" & Chr(10) & "ITEM LCTN]]").Value2 = My_Range4.Value2

BlankCount = Application.CountBlank(ws2.ListObjects("G2JobList").ListColumns("Record").DataBodyRange)
If BlankCount = 0 Then GoTo EndOfJobListUpdates
    With ws1.Range("tblG2JobList[[#Data],[Record]]").SpecialCells(xlCellTypeBlanks).Delete(xlShiftUp)
    End With

EndOfJobListUpdates:



ws1.Activate
ws1.Range("A1").Select
ActiveWindow.ScrollRow = ActiveCell.Row
wb2.Close SaveChanges:=False 'Un-Remark this line of code after all testing is complete, SPS, 02/07/24



With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .CutCopyMode = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

 

[sspatriots]

When I play around with the code a little using something like what I have below, it will populate only the first two visible rows from the visible range in the source table and every cell in every row after that will appear as "#N/A".

Set ws1 = wb1.Worksheets("PO Job List")
Set ws2 = wb2.Worksheets("Jobs")

Set tbl = ws1.ListObjects("tblG2JobList")

Set lc1 = ws2.ListObjects("G2JobList").ListColumns("Job" & Chr(10) & "Status")
col1 = lc1.Range.Column

ws2.ListObjects("G2JobList").Range.AutoFilter Field:=col1, Criteria1:= _
    Array("0 NEW", "1 ACT"), Operator:=xlFilterValues

Set My_Range1 = ws2.Range("G2JobList[[#Data],[Record]:[Job" & Chr(10) & "Status]]")
Set My_Range2 = ws2.Range("G2JobList[[#Data],[G1" & Chr(10) & "Status]:[G1" & Chr(10) & "APPD Date]]")
Set My_Range3 = ws2.Range("G2JobList[[#Data],[G1 MFG" & Chr(10) & "SCHED" & Chr(10) & "Due Date]:[G1" & Chr(10) & "COMPL Date]]")
Set My_Range4 = ws2.Range("G2JobList[[#Data],[Jack" & Chr(10) & "Vendor]:[Wiring" & Chr(10) & "SHPG ARR/" & Chr(10) & "ITEM LCTN]]")

LastRow1 = ws2.Range("G2JobList[#All]").SpecialCells(xlCellTypeLastCell).Row - 1
Set rng1 = ws1.Range("tblG2JobList[#All]").Resize(LastRow1)
tbl.Resize rng1

ws1.Range("tblG2JobList[[#Data],[Record]:[Job" & Chr(10) & "Status]]").Value2 = My_Range1.SpecialCells(xlCellTypeVisible).Value2
ws1.Range("tblG2JobList[[#Data],[G1" & Chr(10) & "Status]:[G1" & Chr(10) & "APPD Date]]").Value2 = My_Range2.SpecialCells(xlCellTypeVisible).Value2
ws1.Range("tblG2JobList[[#Data],[G1 MFG" & Chr(10) & "SCHED" & Chr(10) & "Due Date]:[G1" & Chr(10) & "COMPL Date]]").Value2 = My_Range3.SpecialCells(xlCellTypeVisible).Value2
ws1.Range("tblG2JobList[[#Data],[Jack" & Chr(10) & "Vendor]:[Wiring" & Chr(10) & "SHPG ARR/" & Chr(10) & "ITEM LCTN]]").Value2 = My_Range4.SpecialCells(xlCellTypeVisible).Value2

 

[NateSC]

Here are the pieces you will need, but you are NOT going to drop this straight into your code. It is a fragment from some code I wrote so it is specific to what I was doing. There are a number of worksheets (end in WS), columns (end in Col), rows, etc referenced in the code. tblPts is a table on worksheet PtsWS. You will probably not need the For loop, but I left it in so that you know where the "i" comes from in some of the references.

There is probably a better way to do this, but this solution does work. An alternate would be to use Power Query, but I am a novice with the Power tools.

If you have questions, just ask. Going through someone else's code is usually tricky. I added a bunch of notes to try and help break down the steps.

'Prior to running this, I created an array (myNameArray) to hold each name I was going to filter on.

'For each name in the array, filter by that name, copy the data to the report
    For i = 1 To UBound(myNameArray, 2)
  
        'Find the row I am going to paste into within the destination sheet
        'Prior to this, I copied the header row across to the destination sheet
        myRptRow = myWS.Cells(myWS.Rows.Count, 1).End(xlUp).Row
      
        'If the data is filtered, remove the filters
        If tblPts.ShowAutoFilter Then tblPts.AutoFilter.ShowAllData
      
        'Perform the filter I want for the first name - I have 2 fields I am filtering against
        With tblPts.Range
            .AutoFilter field:=myPNameCol, Criteria1:=myNameArray(1, i) ', Operator:=xlFilterValues
            .AutoFilter field:=myPValidCol, Criteria1:=True ', Operator:=xlFilterValues
        End With
      
        'xlCellTypeVisible only references those cells still visible after the filter
        'I am doing a check on the range and making sure that there were values returned and not just the header row.
        'I don't remember why I looked at both area and rows count.  I think I was double checking I didn't miss some data.
        Set testRng = tblPts.Range.SpecialCells(xlCellTypeVisible)
        numfiltered = testRng.Rows.Count - 1
        numfiltered2 = testRng.Areas.Count - 1
        If numfiltered2 > numfiltered Then numfiltered = numfiltered2
      
        'As long as there is some data, I copy the filtered cells to the destination worksheet
        If numfiltered > 0 Then
            With PtsWS
                .Range(.Cells(2, 1), .Cells(myPtsRows, myNumCols)).SpecialCells(xlCellTypeVisible).Copy _
                    Destination:=myWS.Rows(myRptRow + 1)
            End With
        End If
              
    Next i

 

[NateSC]

I just saw it referenced myPtsRows and myNumCols. This pulls the total number of rows and columns from the sheet I am copying from. I remove filters prior to pulling this data. This code is above what I posted previously.

 If tblPts.ShowAutoFilter Then tblPts.AutoFilter.ShowAllData
    myNumCols = PtsWS.Cells(1, PtsWS.Columns.Count).End(xlToLeft).Column
    myPtsRows = PtsWS.Cells(PtsWS.Rows.Count, 1).End(xlUp).Row

 

[sspatriots]

Here are the pieces you will need, but you are NOT going to drop this straight into your code. It is a fragment from some code I wrote so it is specific to what I was doing. There are a number of worksheets (end in WS), columns (end in Col), rows, etc referenced in the code. tblPts is a table on worksheet PtsWS. You will probably not need the For loop, but I left it in so that you know where the "i" comes from in some of the references.

There is probably a better way to do this, but this solution does work. An alternate would be to use Power Query, but I am a novice with the Power tools.

If you have questions, just ask. Going through someone else's code is usually tricky. I added a bunch of notes to try and help break down the steps.

'Prior to running this, I created an array (myNameArray) to hold each name I was going to filter on.

'For each name in the array, filter by that name, copy the data to the report
    For i = 1 To UBound(myNameArray, 2)
 
        'Find the row I am going to paste into within the destination sheet
        'Prior to this, I copied the header row across to the destination sheet
        myRptRow = myWS.Cells(myWS.Rows.Count, 1).End(xlUp).Row
     
        'If the data is filtered, remove the filters
        If tblPts.ShowAutoFilter Then tblPts.AutoFilter.ShowAllData
     
        'Perform the filter I want for the first name - I have 2 fields I am filtering against
        With tblPts.Range
            .AutoFilter field:=myPNameCol, Criteria1:=myNameArray(1, i) ', Operator:=xlFilterValues
            .AutoFilter field:=myPValidCol, Criteria1:=True ', Operator:=xlFilterValues
        End With
     
        'xlCellTypeVisible only references those cells still visible after the filter
        'I am doing a check on the range and making sure that there were values returned and not just the header row.
        'I don't remember why I looked at both area and rows count.  I think I was double checking I didn't miss some data.
        Set testRng = tblPts.Range.SpecialCells(xlCellTypeVisible)
        numfiltered = testRng.Rows.Count - 1
        numfiltered2 = testRng.Areas.Count - 1
        If numfiltered2 > numfiltered Then numfiltered = numfiltered2
     
        'As long as there is some data, I copy the filtered cells to the destination worksheet
        If numfiltered > 0 Then
            With PtsWS
                .Range(.Cells(2, 1), .Cells(myPtsRows, myNumCols)).SpecialCells(xlCellTypeVisible).Copy _
                    Destination:=myWS.Rows(myRptRow + 1)
            End With
        End If
             
    Next i

Thank you. I will go over this after my lunch break and see if I can put it to use. Regards, SS