VBA Script Edits: Secondary Filter+Sort+Export

[Zarfot]

Geniuses,

I am trying to adapt a script I have to add a more complicated step in filtering, sorting, and looping through my data.

Range 1 = Column I2:I
Range 2 = Column J2:J

Basically, I need a way to rework the code to select the first unique value in Range 1, then select the first unique value in Range 2, and run a sort and export. THEN, start the process over, however select the first unique value in Range 1, and select the SECOND unique value in Range 2, and run a sort. This would continue until all unique values in Range 2 are exhausted, at which point I would want the script to move to the second unique value in Range 1. This would repeat until all values in both ranges are processed.

Here is the current code that only selects from Range 1:

Set Rng = ws3.Range("i2:i" & ws3.Cells(Rows.Count, "i").End(xlUp).Row)
Rng.Sort Key1:=ws3.Range("I1"), Order1:=xlAscending

This would need to be adapted to also include values from Range 2 somewhere where it mentions Range.Autofilter Field:=2. In this case, Range 1 is Field:=2, and Range 2 is Field:=3

lRow = 6 'set current last row for start of ws3 summary sheet
 
'loop to copy row 3 from ws1 to ws2
 
For Each cell In Rng
 
    'increment last row
    i = i + 1
 
    With ws1
        .ListObjects("Table3").Range.AutoFilter Field:=2, Criteria1:=cell.Value
        .Range("B3:E3").Copy
        ws2.Range("B" & lRow + i).PasteSpecial xlPasteValues
    End With

The main reason why is I want to export a table showing unique threat values covering a specific area. Right now, the code only exports 1 threat per area, not multiple.

Example of the Dataset:

Inspection	Area	Threat	Condition	Sq. Footage
Inspection_1	300A	Green	Good	3000
Inspection_1	300A	Amber	Poor	2000
Inspection_1	300A	Amber	Poor	1000
Inspection_1	101C	Red	Damaged	5000
Inspection_1	101C	Red	Damaged	4000
Inspection_2	400A	Red	Damaged	300
Inspection_2	400B	Red	Damaged	100
Inspection_2	400A	Green	Good	50000
Inspection_2	400B	Amber	Poor	750
Inspection_2	221X	Yellow	Okay	20000
Inspection_3	X7647	Green	Good	58000
Inspection_3	X7647	Yellow	Okay	9000
Inspection_3	X2243	Red	Damaged	90
Inspection_3	X2243	Green	Good	600
Inspection_3	X2243	Green	Good	400

<tbody>
</tbody>

Example of what the script currently does (when filtered for Inspection_1 as desired):

Area	Threat	Condition	Sq. Footage
101C	Red	Damaged	9000
300A	Green	Good	6000

<tbody>
</tbody>

Example of what I want (when filtered for Inspection_1 as desired):

Area	Threat	Condition	Sq. Footage
300A	Green	Good	3000
300A	Amber	Poor	3000
101C	Red	Damaged	9000

<tbody>
</tbody>

Link to workbook file:
http://s000.tinyupload.com/download.php?file_id=61404658697921899524&t=6140465869792189952468930


Full Code:

Option Explicit
 
Sub Loop1()
Dim cell As Range 'loop range
Dim Rng As Range 'range for unique values
 
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
 
Dim lRow As Long 'last row in Inspection sheet
Dim i As Integer 'counter
 
Set ws1 = Worksheets("Data")
Set ws2 = Worksheets("Inspection")
Set ws3 = Worksheets("NamedRange")
 
Application.ScreenUpdating = False
 
'reset autofilter
ws1.ListObjects("Table3").Range.AutoFilter
 
'autofilter on Inspection selected
ws1.ListObjects("Table3").Range.AutoFilter Field:=1, Criteria1:=ws2.Range("C3")
 
'copy Column B in Table3 to NamedRange!I1
ws1.Range("B6:B20").SpecialCells(xlVisible).Copy 'extend range when needed
ws3.Range("I1").PasteSpecial
 
'copy Column C in Table3 to NamedRange!J1
ws1.Range("C6:C20").SpecialCells(xlVisible).Copy 'extend range when needed
ws3.Range("J1").PasteSpecial
 
'Remove duplicates for unique values
ws3.Columns("I:I").RemoveDuplicates Columns:=1, Header:=xlYes
 
'Remove duplicates for unique values
ws3.Columns("J:J").RemoveDuplicates Columns:=1, Header:=xlYes
 
'set range for loop and sort
Set Rng = ws3.Range("i2:i" & ws3.Cells(Rows.Count, "i").End(xlUp).Row)
Rng.Sort Key1:=ws3.Range("I1"), Order1:=xlAscending
 
lRow = 6 'set current last row for start of ws3 summary sheet
 
'loop to copy row 3 from ws1 to ws2
 
For Each cell In Rng
 
    'increment last row
    i = i + 1
 
    With ws1
        .ListObjects("Table3").Range.AutoFilter Field:=2, Criteria1:=cell.Value
        .Range("B3:E3").Copy
        ws2.Range("B" & lRow + i).PasteSpecial xlPasteValues
    End With
 
Next
 
'goto ws2.Range
Application.Goto ws2.Range("B6")
 
Application.ScreenUpdating = True
 
End Sub

Thanks for the help!

 

[Zarfot]

Bumping for visibility.

 

[Zarfot]

Bumping for visibility and help.