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:

[TABLE="width: 413"]
<tbody>[TR]
[TD]Inspection[/TD]
[TD]Area[/TD]
[TD]Threat[/TD]
[TD]Condition[/TD]
[TD]Sq. Footage[/TD]
[/TR]
[TR]
[TD]Inspection_1[/TD]
[TD]300A[/TD]
[TD]Green[/TD]
[TD]Good[/TD]
[TD]3000[/TD]
[/TR]
[TR]
[TD]Inspection_1[/TD]
[TD]300A[/TD]
[TD]Amber[/TD]
[TD]Poor[/TD]
[TD]2000[/TD]
[/TR]
[TR]
[TD]Inspection_1[/TD]
[TD]300A[/TD]
[TD]Amber[/TD]
[TD]Poor[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]Inspection_1[/TD]
[TD]101C[/TD]
[TD]Red[/TD]
[TD]Damaged[/TD]
[TD]5000[/TD]
[/TR]
[TR]
[TD]Inspection_1[/TD]
[TD]101C[/TD]
[TD]Red[/TD]
[TD]Damaged[/TD]
[TD]4000[/TD]
[/TR]
[TR]
[TD]Inspection_2[/TD]
[TD]400A[/TD]
[TD]Red[/TD]
[TD]Damaged[/TD]
[TD]300[/TD]
[/TR]
[TR]
[TD]Inspection_2[/TD]
[TD]400B[/TD]
[TD]Red[/TD]
[TD]Damaged[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD]Inspection_2[/TD]
[TD]400A[/TD]
[TD]Green[/TD]
[TD]Good[/TD]
[TD]50000[/TD]
[/TR]
[TR]
[TD]Inspection_2[/TD]
[TD]400B[/TD]
[TD]Amber[/TD]
[TD]Poor[/TD]
[TD]750[/TD]
[/TR]
[TR]
[TD]Inspection_2[/TD]
[TD]221X[/TD]
[TD]Yellow[/TD]
[TD]Okay[/TD]
[TD]20000[/TD]
[/TR]
[TR]
[TD]Inspection_3[/TD]
[TD]X7647[/TD]
[TD]Green[/TD]
[TD]Good[/TD]
[TD]58000[/TD]
[/TR]
[TR]
[TD]Inspection_3[/TD]
[TD]X7647[/TD]
[TD]Yellow[/TD]
[TD]Okay[/TD]
[TD]9000[/TD]
[/TR]
[TR]
[TD]Inspection_3[/TD]
[TD]X2243[/TD]
[TD]Red[/TD]
[TD]Damaged[/TD]
[TD]90[/TD]
[/TR]
[TR]
[TD]Inspection_3[/TD]
[TD]X2243[/TD]
[TD]Green[/TD]
[TD]Good[/TD]
[TD]600[/TD]
[/TR]
[TR]
[TD]Inspection_3[/TD]
[TD]X2243[/TD]
[TD]Green[/TD]
[TD]Good[/TD]
[TD]400[/TD]
[/TR]
</tbody>[/TABLE]


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

[TABLE="width: 408"]
<tbody>[TR]
[TD]Area[/TD]
[TD]Threat[/TD]
[TD]Condition[/TD]
[TD]Sq. Footage[/TD]
[/TR]
[TR]
[TD]101C[/TD]
[TD]Red[/TD]
[TD]Damaged[/TD]
[TD]9000[/TD]
[/TR]
[TR]
[TD]300A[/TD]
[TD]Green[/TD]
[TD]Good[/TD]
[TD]6000[/TD]
[/TR]
</tbody>[/TABLE]


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

[TABLE="width: 429"]
<tbody>[TR]
[TD]Area[/TD]
[TD]Threat[/TD]
[TD]Condition[/TD]
[TD]Sq. Footage[/TD]
[/TR]
[TR]
[TD]300A[/TD]
[TD]Green[/TD]
[TD]Good[/TD]
[TD]3000[/TD]
[/TR]
[TR]
[TD]300A[/TD]
[TD]Amber[/TD]
[TD]Poor[/TD]
[TD]3000[/TD]
[/TR]
[TR]
[TD]101C[/TD]
[TD]Red[/TD]
[TD]Damaged[/TD]
[TD]9000[/TD]
[/TR]
</tbody>[/TABLE]

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.