```
Sub LoopThroughSheetsAndPasteDataWithArray()
Dim ws As Worksheet
Dim wsMain As Worksheet
Dim filterCriteria As String
Dim lastRow As Long
Dim uniqueValues() As Variant
Dim i As Long
UniqueValuesToArray uniqueValues
Set wsMain = ThisWorkbook.Sheets("VGT Log")
wsMain.Cells.UnMerge
Call SortSheetsByNameAndMove
lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "VGT Log" Then
filterCriteria = ws.Name
If Not IsInArray(filterCriteria, uniqueValues) Then
ws.Cells.ClearContents
End If
ws.Cells.UnMerge
With wsMain
.AutoFilterMode = False
.Range("D3").AutoFilter Field:=4, Criteria1:=filterCriteria
If Application.WorksheetFunction.Subtotal(103, .Range("D4:D" & lastRow)) > 1 Then
.Range("A4:K" & lastRow).Copy
ws.Range("A4").PasteSpecial xlPasteValues
End If
End With
End If
Next ws
ThisWorkbook.Sheets("VGT Log").AutoFilterMode = False
End Sub
Function IsInArray(value As Variant, arr As Variant) As Boolean
Dim element As Variant
For Each element In arr
If element = value Then
IsInArray = True
Exit Function
End If
Next element
IsInArray = False
End Function
Sub UniqueValuesToArray(ByRef uniqueValues() As Variant)
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
Dim value As Variant
Dim isUnique As Boolean
Dim i As Long
Set ws = ThisWorkbook.Sheets("VGT Log")
lastRow = ws.Cells(Rows.Count, "D").End(xlUp).Row
ReDim uniqueValues(1 To lastRow - 3)
i = 1
For Each cell In ws.Range("D4:D" & lastRow)
value = cell.value
isUnique = True
For j = 1 To i - 1
If uniqueValues(j) = value Then
isUnique = False
Exit For
End If
Next j
If isUnique Then
uniqueValues(i) = value
i = i + 1
End If
Next cell
ReDim Preserve uniqueValues(1 To i - 1)
End Sub
Sub SortSheetsByNameAndMove()
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Integer, j As Integer
Dim sheetNames() As String
Dim vgtLogIndex As Integer
Dim unknownIndex As Integer
Set wb = ThisWorkbook
ReDim sheetNames(1 To wb.Sheets.Count)
i = 1
For Each ws In wb.Sheets
sheetNames(i) = ws.Name
i = i + 1
Next ws
For i = 1 To UBound(sheetNames)
For j = i + 1 To UBound(sheetNames)
If UCase(sheetNames(i)) > UCase(sheetNames(j)) Then
Dim tempName As String
tempName = sheetNames(i)
sheetNames(i) = sheetNames(j)
sheetNames(j) = tempName
End If
Next j
Next i
For i = 1 To UBound(sheetNames)
wb.Sheets(sheetNames(i)).Move After:=wb.Sheets(wb.Sheets.Count)
Next i
vgtLogIndex = 0
unknownIndex = 0
For i = 1 To UBound(sheetNames)
If sheetNames(i) = "VGT Log" Then
vgtLogIndex = i
ElseIf sheetNames(i) = "Unknown" Then
unknownIndex = i
End If
Next i
If vgtLogIndex > 0 Then
wb.Sheets(sheetNames(vgtLogIndex)).Move Before:=wb.Sheets(1)
End If
If unknownIndex > 0 Then
wb.Sheets(sheetNames(unknownIndex)).Move Before:=wb.Sheets(2)
End If
End Sub
```