Sub Admin_filter_loop()
'from admin list loop through sheets and perform argument three filters
Dim ws As Worksheet, dws As Worksheet, admWs As Worksheet
Dim lr As Long, alr As Long, i As Long, dlr As Long
Dim x
With Application
.StatusBar = "MACRO IN PROGRESS please wait......"
.ScreenUpdating = False
.DisplayAlerts = False
Set dws = Sheets("percent upload")
Set admWs = Sheets("Admin")
'Inserts headers
dws.Range("A1:F1").Value = Array("Comments", "Branch", "Line", "Layout", "Section", "Override")
alr = admWs.Cells(Rows.Count, 2).End(xlUp).Row
If alr < 5 Then
MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
Exit Sub
End If
x = admWs.Range("B5:B" & alr).Value
For i = 1 To UBound(x, 1)
Set ws = Sheets(x(i, 1))
If Not ws Is Nothing Then
Three_filters_argument ws
End If
Next i
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = False
End With
MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub
'Filters ARGUMENT
'APPLY 3 FILTERS
Sub Three_filters_argument(ws As Worksheet)
' three_filters Macr
Application.ScreenUpdating = False
'PERFORM FIRST FILTER
'switch off auto calcs to speed up code
Application.Calculation = xlCalculationManual
Dim rRng As Range
With ws
If .AutoFilterMode = True Then
.Range("A1").AutoFilter ''/// not sure what you expect the selection to be, amend accordingly
End If
xrow = .Cells(.Rows.Count, 27).End(xlUp).Row
.Range("V5").AutoFilter
.Range("$V$5:$z$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
'if header row or blank exclude otherwise copy visible rows
headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
flag = 0
For Each rngrow In filteredrange.Rows
lastrow = rngrow.Row
If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
flag = 1
firstrow = rngrow.Row
End If
Next
If firstrow > 0 Then
Range("V" & firstrow & ":Z" & lastrow).Copy
With Sheets("percent upload")
If .Range("B2").Value = "" Then
Set rRng = .Range("B2")
Else
Set rRng = .Range("B1").End(xlDown).Offset(1, 0).Select
End If
rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
End If
'PERFORM SECOND FILTER
If .AutoFilterMode = True Then
.Range("A1").AutoFilter
End If
xrow = .Cells(.Rows.Count, 33).End(xlUp).Row
Range("AA5").AutoFilter
.Range("$AA$5:$AE$" & xrow).AutoFilter field:=2, Criteria1:=">1", Operator:=xlAnd
Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
flag = 0
For Each rngrow In filteredrange.Rows
lastrow = rngrow.Row
If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
flag = 1
firstrow = rngrow.Row
End If
Next
If firstrow > 0 Then
.Range("AA" & firstrow & ":AE" & lastrow).Copy
With Sheets("percent upload")
If .Range("B2").Value = "" Then
Set rRng = Range("B2")
Else
Set rRng = Range("B1").End(xlDown).Offset(1, 0)
End If
rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
End If
'PERFORM THIRD FILTER 7 TIMES i.e each copied set into absolute upload is equivalent to one day
Dim x
If .AutoFilterMode = True Then
.Range("A1").AutoFilter
End If
xrow = .Cells(.Rows.Count, 33).End(xlUp).Row
.Range("AG5").AutoFilter
.Range("$AG$5:$AH$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
flag = 0
For Each rngrow In filteredrange.Rows
lastrow = rngrow.Row
If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
flag = 1
firstrow = rngrow.Row
End If
Next
If firstrow > 0 And .Cells(firstrow, "AG") <> "" Then
Set rRng = .Range("AG" & firstrow & ":AH" & lastrow)
Let x = 0
Do While x < 7
rRng.Copy
With Sheets("absolute upload")
If .Range("A2").Value = "" Then
Set rRng = .Range("A2")
Else
Set rRng = .Range("A1").End(xlDown).Offset(1, 0)
End If
rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
x = x + 1
End With
Loop
' .Range("a1").Select
End If
Application.Calculation = xlCalculationAutomatic
End With
End Sub
Sub Admin_filter_loop()
'from admin list loop through sheets and perform argument three filters
Dim ws As Worksheet, dws As Worksheet, admws As Worksheet
Dim lr As Long, alr As Long, i As Long, dlr As Long
Dim x
With Application
.StatusBar = "MACRO IN PROGRESS please wait......"
.ScreenUpdating = False
.DisplayAlerts = False
Set dws = Sheets("percent upload")
Set admws = Sheets("Admin")
'Inserts headers
dws.Range("A1:F1").Value = Array("Comments", "Branch", "Line", "Layout", "Section", "Override")
alr = admws.Cells(Rows.Count, 2).End(xlUp).Row
If alr < 5 Then
MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
Exit Sub
End If
x = admws.Range("B5:B" & alr).Value
For i = 1 To UBound(x, 1)
Set ws = Sheets(x(i, 1))
If Not ws Is Nothing Then
Three_filters_argument ws
End If
Next i
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = False
End With
MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub
'APPLY 3 FILTERS
Sub Three_filters_argument(ws As Worksheet)
'
'
'PERFORM FIRST FILTER
'switch off auto calcs to speed up code
Application.Calculation = xlCalculationManual
Dim rRng As Range, rRng2 As Range
With ws
If .AutoFilterMode = True Then
.Range("A1").AutoFilter
End If
xrow = .Cells(.Rows.Count, 22).End(xlUp).Row
.Range("V5").AutoFilter
.Range("$V$5:$z$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
'if header row or blank exclude otherwise copy visible rows
headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
flag = 0
For Each rngrow In filteredrange.Rows
lastrow = rngrow.Row
If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
flag = 1
firstrow = rngrow.Row
End If
Next
If firstrow > 0 Then
.Range("V" & firstrow & ":Z" & lastrow).Copy
With Sheets("percent upload")
If .Range("B2").Value = "" Then
Set rRng = .Range("B2")
Else
Set rRng = .Range("B1").End(xlDown).Offset(1, 0)
End If
rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
End If
'PERFORM SECOND FILTER
If .AutoFilterMode = True Then
.Range("A1").AutoFilter
End If
xrow = .Cells(.Rows.Count, 27).End(xlUp).Row
.Range("AA5").AutoFilter
.Range("$AA$5:$AE$" & xrow).AutoFilter field:=2, Criteria1:=">1", Operator:=xlAnd
Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
flag = 0
For Each rngrow In filteredrange.Rows
lastrow = rngrow.Row
If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
flag = 1
firstrow = rngrow.Row
End If
Next
If firstrow > 0 Then
.Range("AA" & firstrow & ":AE" & lastrow).Copy
With Sheets("percent upload")
If .Range("B2").Value = "" Then
Set rRng = .Range("B2")
Else
Set rRng = .Range("B1").End(xlDown).Offset(1, 0)
End If
rRng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
End If
'PERFORM THIRD FILTER 7 TIMES i.e each copied set into absolute upload is equivalent to one day
Dim x As Integer
If .AutoFilterMode = True Then .Range("A1").AutoFilter
xrow = .Cells(.Rows.Count, 33).End(xlUp).Row
.Range("AG5").AutoFilter
.Range("$AG$5:$AH$" & xrow).AutoFilter field:=1, Criteria1:=">1", Operator:=xlAnd
Set filteredrange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
headerrow = .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas(1).Row
flag = 0
For Each rngrow In filteredrange.Rows
lastrow = rngrow.Row
If rngrow.Hidden = False And rngrow.Row <> headerrow And flag = 0 Then
flag = 1
firstrow = rngrow.Row
End If
Next
If firstrow > 0 And .Cells(firstrow, "AG") <> "" Then
Set rRng = .Range("AG" & firstrow & ":AH" & lastrow)
rRng.Copy
x = 0
Do While x < 8
With Sheets("absolute upload")
If .Range("A2").Value = "" Then
Set rRng2 = .Range("A2")
Else
Set rRng2 = .Range("A1").End(xlDown).Offset(1, 0)
End If
rRng2.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
x = x + 1
End With
Loop
End If
End With
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
VBA MS Word "Table of Contents" extractor` | 4 | 26 | |
change the windows script file to BAT | 10 | 31 | |
Add a range in an Excel graph | 5 | 36 | |
Excel vba to add signature to email when created | 11 | 43 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
20 Experts available now in Live!