Select from freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely and get projects done right.
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 |
---|---|---|---|
Select only certain columns not entire sheet | 12 | 26 | |
Archiving Access table older than 6 months | 9 | 38 | |
conditional formatting | 4 | 41 | |
Why do my Excel files become huge? | 27 | 27 |
Join the community of 500,000 technology professionals and ask your questions.