I have a macro that runs an anti-filter concept and pastes the results into a sheet called "AF".
How can I adjust this so instead of pasting Column T from "CurrentList" it pastes columns A:Q. I tried tweaking some of the variables.
Option Explicit
Sub XC()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim src As Worksheet
Set src = wb.Worksheets("CurrentList")
Dim LastRow As Long
LastRow = src.Cells(src.Rows.Count, "S").End(xlUp).Row
Dim rng As Range
Set rng = src.Range("S1").Resize(LastRow)
Dim Lookup As Variant
Lookup = rng.Value
Set rng = src.Range("T1").Resize(LastRow)
Dim Result As Variant
Result = rng.Value
Dim LookupValue As Variant
Dim i As Long
Dim MatchCount As Long
For i = 1 To UBound(Lookup)
LookupValue = Lookup(i, 1)
If Not IsError(LookupValue) Then
If LookupValue = "Yes" Then
MatchCount = MatchCount + 1
Result(MatchCount, 1) = Result(i, 1)
End If
End If
Next i
If MatchCount = 0 Then
Exit Sub
End If
Dim dst As Worksheet
Set dst = wb.Worksheets("AF")
Set rng = dst.Cells(dst.Rows.Count, "A").End(xlUp).Offset(1)
Set rng = rng.Resize(MatchCount)
rng.Value = Result
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
Give this a try. You'll have to adjust sheet names.
Sub x()
Dim rData As Range
Application.ScreenUpdating = False
With Worksheets("CurrentList")
.AutoFilterMode = False
.Range("A1").CurrentRegion.AutoFilter field:=19, Criteria1:="Yes"
With .AutoFilter.Range
On Error Resume Next
Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rData Is Nothing Then
Intersect(rData, .Range("A:Q")).Copy Worksheets("AF").Range("A" & Rows.Count).End(xlUp)(2)
End If
End With
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Related
I am trying to extract listobject filtered data to a new workbook. However, all data is extracted instead of just the filtered data.
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
ColNum = Application.WorksheetFunction.Match("DateOrder", wsCopy.Rows(1), 0)
With loop_obj
.Range.AutoFilter Field:=ColNum, Criteria1:=">=0"
End With
'Add Copy Values to Array
Set loop_copy = loop_obj.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
arr = loop_copy.CurrentRegion.Offset(1, 0)
aRws = Evaluate("Row(1:" & UBound(arr) & ")")
arr = Application.Index(arr, aRws, Array(1, 2, 3, 4, 5))
'Create New Workbook with a Blank Worksheet
wb.Worksheets.Add.Move
Set wb_new = ActiveWorkbook
Set wsDest = ActiveWorkbook.ActiveSheet
'Perform Paste Operations
Set loop_paste = wsDest.Range("A1")
loop_paste.Resize(UBound(arr, 1), UBound(arr, 2)).value = arr
With wsDest
.Range(Cells(1, DateNum), Cells(1200, DateNum)).NumberFormat = "[$-en-US]d-mmm-yy;#"
.Parent.SaveAs FileName:=dFilePath, FileFormat:=xlCSVUTF8
.Parent.Close True
End With
loop_obj.AutoFilter.ShowAllData
This worked for me (just copy each column based off the array of column indexes):
Sub tester()
Dim wsCopy As Worksheet, loop_copy As Range
Dim loop_obj As ListObject, colnum As Long
Dim col, visRows As Long, rngDest As Range, i As Long
Set wsCopy = Sheets("Details")
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
colnum = Application.Match("DateOrder", loop_obj.HeaderRowRange, 0)
If IsError(colnum) Then
MsgBox "Header not found!"
Exit Sub
End If
Application.ScreenUpdating = False
loop_obj.Range.AutoFilter Field:=colnum, Criteria1:=">=0"
On Error Resume Next 'in case no visible rows to count
visRows = loop_obj.DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible).Count
On Error GoTo 0
If visRows > 0 Then
Set rngDest = Sheets("destination").Range("B2")
i = 0
For Each col In Array(1, 2, 3, 4, 5)
loop_obj.DataBodyRange.Columns(col).SpecialCells(xlCellTypeVisible).Copy
rngDest.Parent.Paste Destination:=rngDest.Offset(0, i)
i = i + 1
Next col
End If
loop_obj.AutoFilter.ShowAllData
End Sub
EDIT: a different array-based approach - this is faster, but again it's more complex, so there's a trade-off.
Sub Tester()
Dim wsCopy As Worksheet, loop_copy As Range
Dim loop_obj As ListObject, colnum As Long
Dim col, visRows As Long, rngDest As Range, i As Long, data
Set wsCopy = Sheets("Details")
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
colnum = Application.Match("DateOrder", loop_obj.HeaderRowRange, 0)
If IsError(colnum) Then
MsgBox "Header not found!"
Exit Sub
End If
Application.ScreenUpdating = False
loop_obj.Range.AutoFilter Field:=colnum, Criteria1:=">=0"
data = arrayFromVisibleRows(loop_obj.DataBodyRange)
If Not IsEmpty(data) Then
With Sheets("Destination").Range("B2")
.CurrentRegion.ClearContents
.Resize(UBound(data, 1), UBound(data, 2)).Value = data
End With
End If
loop_obj.AutoFilter.ShowAllData
End Sub
'Return a 2D array using only visible row in `rng`
' Optionally include only column indexes in `cols` (passed as a 1D array)
Function arrayFromVisibleRows(rng As Range, Optional cols As Variant = Empty)
Dim rngVis As Range, data, dataOut
Dim rw As Long, col, e, c As Range, cOut As Long, rOut As Long, srcRow As Long
On Error Resume Next
Set rngVis = rng.Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngVis Is Nothing Then
data = rng.Value 'read all the range data to an array
If IsEmpty(cols) Then
'create an array with all column indexes if none were provided
cols = Application.Transpose(Evaluate("=ROW(1:" & rng.Columns.Count & ")"))
End If
'size the output array
ReDim dataOut(1 To rngVis.Cells.Count, 1 To (UBound(cols) - LBound(cols)) + 1)
rOut = 1
For Each c In rngVis.Cells
cOut = 1
srcRow = 1 + (c.Row - rng.Cells(1).Row)
For Each col In cols 'loop the required columns
dataOut(rOut, cOut) = data(srcRow, col)
cOut = cOut + 1
Next col
rOut = rOut + 1
Next c
arrayFromVisibleRows = dataOut
Else
arrayFromVisibleRows = Empty
End If
End Function
I think that this is close to what the OP wants. I didn't bother saving the file because its not relevant to my test and I added column headers.
Sub Main()
Dim tCopyTable As ListObject
Set tCopyTable = wsCopy.ListObjects(1)
Dim DateOrder As ListColumn
Dim Source As Range
With tCopyTable
If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
Set DateOrder = tCopyTable.ListColumns("DateOrder")
.Range.AutoFilter Field:=DateOrder.Index, Criteria1:=">=0"
Set Source = .Range.Offset(1)
End With
Dim CountOfVisibleDates As Long
CountOfVisibleDates = WorksheetFunction.Subtotal(103, Source.Columns(DateOrder.Index))
If CountOfVisibleDates > 0 Then
Dim wb As Workbook
Set wb = Workbooks.Add
With wb.Worksheets(1)
tCopyTable.HeaderRowRange.Resize(1, 5).Copy .Range("A1")
Source.Resize(, 5).Copy .Range("A2")
End With
End If
End Sub
Note: Looping through the values is almost always much faster than copying ranges.
Addendum
Sub Main2()
Dim tCopyTable As ListObject
Set tCopyTable = wsCopy.ListObjects(1)
Dim DateOrder As ListColumn
Dim Source As Range
With tCopyTable
If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
Set DateOrder = tCopyTable.ListColumns("DateOrder")
.Range.AutoFilter Field:=DateOrder.Index, Criteria1:=">=0"
Set Source = .Range.Offset(1)
End With
Dim CountOfVisibleDates As Long
CountOfVisibleDates = WorksheetFunction.Subtotal(103, Source.Columns(DateOrder.Index))
Dim OriginalColumnOrder As Variant
Dim NewColumnOrder As Variant
OriginalColumnOrder = Array(1, 2, 3, 4, 5)
NewColumnOrder = Array(3, 2, 1, 5, 4)
Dim c As Long
If CountOfVisibleDates > 0 Then
Dim wb As Workbook
Set wb = Workbooks.Add
With wb.Worksheets(1)
For c = 0 To UBound(NewColumnOrder)
tCopyTable.HeaderRowRange.Columns(OriginalColumnOrder(c)).Copy .Rows(1).Columns(NewColumnOrder(c))
Source.Resize(, 5).Columns(OriginalColumnOrder(c)).Copy .Rows(2).Columns(NewColumnOrder(c))
Next
End With
End If
End Sub
Result
I was in a rush. This is all that is needed to copy the headers and filtered data:
tCopyTable.ListColumns(OriginalColumnOrder(c)).Range.Copy .Rows(1).Columns(NewColumnOrder(c))
If you just want the data use:
tCopyTable.ListColumns(OriginalColumnOrder(c)).DataBodyRange.Copy .Rows(1).Columns(NewColumnOrder(c))
I'm trying to compare column A in sheet2 to column A in sheet1 and when there's a match, copy the row from sheet1 to sheet3 with the same order. And if there is a repetition, it should be included too. I also need it to show the mismatching values empty. I did this macro but I can not allow the duplicates to be included.
Sub compareAndCopy()
Dim lastRowE As Long
Dim lastRowF As Long
Dim lastRowM As Long
Dim foundTrue As Boolean
' stop screen from updating to speed things up
Application.ScreenUpdating = False
lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = False
For j = 1 To lastRowF
If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then
lastRowM = lastRowM + 1
Sheets("Sheet1").Rows(i).Copy Destination:= _
Sheets("Sheet3").Rows(lastRowM)
foundTrue = True
Exit For
End If
Next j
'If Not foundTrue Then
' MsgBox ("didn't find string: " & Sheets("Sheet2").Cells(i, 2).value)
'End If
Next i
' allow screen updating
Application.ScreenUpdating = True
End Sub
Group Data
Loops through probably unique values in column A of Sheet2.
For each cell value, it uses the Find and FindNext methods to find all the matching cells in column A of Sheet1.
Then it writes each of the cell values to a key, and using Union, combines each matching cell to a range object in the corresponding item.
Then it loops through the dictionary and copies the entire rows of each item (range) to Sheet3.
Finally, it clears the newly added values in column A of Sheet3.
The result in Sheet3 is data from Sheet1 grouped by the values in column A of Sheet2.
Option Explicit
Sub CompareAndCopy()
Const eName As String = "Sheet2"
Const eCol As String = "A"
Const efRow As Long = 1 ' don't you have headers?
Const fName As String = "Sheet1"
Const fCol As String = "A"
Const ffRow As Long = 1 ' don't you have headers?
Const mName As String = "Sheet3"
Const mCol As String = "B" ' "A" is empty!
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ews As Worksheet: Set ews = wb.Worksheets(eName)
Dim elRow As Long: elRow = ews.Cells(ews.Rows.Count, eCol).End(xlUp).Row
If elRow < efRow Then Exit Sub ' no data
Dim erg As Range: Set erg = ews.Cells(efRow, eCol).Resize(elRow - efRow + 1)
'Debug.Print erg.Address
Dim fws As Worksheet: Set fws = wb.Worksheets(fName)
Dim flRow As Long: flRow = fws.Cells(fws.Rows.Count, fCol).End(xlUp).Row
If flRow < ffRow Then Exit Sub ' no data
Dim frg As Range:
Set frg = fws.Cells(ffRow, fCol).Resize(flRow - ffRow + 1)
'Debug.Print frg.Address
Dim mws As Worksheet: Set mws = wb.Worksheets(mName)
Dim mifCell As Range
Set mifCell = mws.Cells(mws.Rows.Count, mCol).End(xlUp).Offset(1) _
.EntireRow.Columns("A") ' entire rows
Dim mfCell As Range: Set mfCell = mifCell
'Debug.Print mfCell.Address
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Application.ScreenUpdating = False
Dim frCount As Long: frCount = frg.Rows.Count
Dim eCell As Range
Dim eValue As Variant
Dim fCell As Range
Dim FirstAddress As String
For Each eCell In erg.Cells
eValue = eCell.Value
Set fCell = frg.Find(eValue, frg.Cells(frCount), xlFormulas, xlWhole)
If Not fCell Is Nothing Then
FirstAddress = fCell.Address
Do
If dict.Exists(eValue) Then
Set dict(eValue) = Union(dict(eValue), fCell)
Else
Set dict(eValue) = fCell
End If
Set fCell = frg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
End If
Next eCell
If dict.Count = 0 Then Exit Sub ' no data¸
Dim rg As Range
Dim Item As Variant
Dim irCount As Long
For Each Item In dict.Items
irCount = Item.Cells.Count
'Debug.Print Item.Address, irCount
Item.EntireRow.Copy mfCell.EntireRow
Set mfCell = mfCell.Offset(irCount)
Next Item
mifCell.Resize(mfCell.Row - mifCell.Row).ClearContents ' or .Clear
Application.ScreenUpdating = True
MsgBox "Data grouped.", vbInformation
End Sub
I have the following code that does a great job at copying relevant data into my sheets. I create each sheet manually for every unique department in column J, then I run this macro. I would like a macro that creates the sheets dynamically based on unique values within column J. I have found good resources online but the ones I've found seem to error when it reaches a row that has already had a sheet created for it. I have included the code I'm currently using as well as a screenshot of my inventory sheet before I manually create the other worksheets
Sub CopyRows()
Dim bottomJ As Integer
bottomJ = Range("J" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
For Each c In Sheets("All Dept.").Range("J2:J" & bottomJ)
For Each ws In Sheets
ws.Activate
If ws.Name = c Then
c.EntireRow.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next ws
Next c
End Sub
Try this.
Sub CreateSheets()
Dim rng As Range
Dim cl As Range
Dim dic As Object
Dim ky As Variant
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
Set rng = .Range(.Range("J2"), .Range("J" & .Rows.Count).End(xlUp))
End With
For Each cl In rng
If Not dic.exists(cl.Value) Then
dic.Add cl.Value, cl.Value
End If
Next cl
For Each ky In dic.keys
Sheets.Add(After:=Sheets(Sheets.Count)).Name = dic(ky)
Next ky
End Sub
Create Criteria Worksheets
The problem with your idea is e.g. that you use the Hafiz Sb's CreateSheets procedure to create the worksheets and then you use your CopyRows procedure to write the data. Now you add more data to the main worksheet and you're stuck. How will you add the new data to the respective worksheets?
The following assumes that you will only add, not delete data from the main worksheet.
It will copy the main worksheet as many times as there are unique values in a column ('scCol') and by using Autofilter, will delete the undesired data on each of the worksheets (it is my idea, but something similar (if not the same) was suggested by Cyril in the comments).
I did something similar here, which writes the worksheets to separate workbooks.
Option Explicit
Sub CriteriaWorksheetsCreator()
' Accompanying procedures:
' ArrUniqueColumnRange
' DeleteWorksheetsViaArray
Const sName As String = "All Dept."
Const sFirst As String = "A1"
Const sfRow As Long = 1 ' Header Row
Const scCol As Long = 10 ' Criteria Column
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim rg As Range: Set rg = sws.Range(sFirst).CurrentRegion
If rg.Rows.Count = 1 Then Exit Sub ' only one (header) row
If rg.Columns.Count < scCol Then Exit Sub ' too few columns
Dim strg As Range
Set strg = rg.Resize(rg.Rows.Count - sfRow + 1).Offset(sfRow - 1)
Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
Dim scrg As Range: Set scrg = sdrg.Columns(scCol)
Dim wsNames As Variant: wsNames = ArrUniqueColumnRange(scrg)
If IsEmpty(wsNames) Then Exit Sub ' no valid data in 'scrg'
Dim tAddress As String: tAddress = strg.Address
Dim cAddress As String: cAddress = scrg.Address
Application.ScreenUpdating = False
DeleteWorksheetsViaArray wb, wsNames
Dim dws As Worksheet
Dim dtrg As Range
Dim dcrg As Range
Dim drg As Range
Dim n As Long
Dim dName As String
For n = 0 To UBound(wsNames)
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set dws = ActiveSheet
dName = wsNames(n)
dws.Name = dName
Set dtrg = dws.Range(tAddress)
dtrg.AutoFilter scCol, "<>" & dName
If Application.Subtotal(103, dtrg.Columns(scCol)) > 1 Then
Set dcrg = dws.Range(cAddress)
Set drg = dcrg.SpecialCells(xlCellTypeVisible).EntireRow
drg.Delete
End If
dws.AutoFilterMode = False
Next n
sws.Activate
'wb.Save
Application.ScreenUpdating = True
MsgBox "Criteria worksheets created.", _
vbInformation, "Criteria Worksheets Creator"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values from the first column of a range,
' in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueColumnRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
Dim Data As Variant
Dim rCount As Long
With rg.Columns(1)
rCount = .Rows.Count
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
Else
Data = .Value
End If
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
Dim Key As Variant
Dim r As Long
For r = 1 To rCount
Key = Data(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = Empty
End If
End If
Next r
If .Count = 0 Then Exit Function ' only error values and/or blanks
ArrUniqueColumnRange = .keys
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Deletes all worksheets whose names are in an array ('wsNames'),
' from a workbook ('wb').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DeleteWorksheetsViaArray( _
ByVal wb As Workbook, _
ByVal wsNames As Variant)
On Error GoTo ClearError
If wb Is Nothing Then Exit Sub
Dim LB As Long: LB = LBound(wsNames)
Dim UB As Long: UB = UBound(wsNames)
Dim wsnCount As Long: wsnCount = UB - LB + 1
Dim DeleteSheetNames() As String: ReDim DeleteSheetNames(0 To wsnCount - 1)
Dim dn As Long
Dim ws As Worksheet
Dim sn As Long
Dim wsName As String
For sn = LB To UB
wsName = wsNames(sn)
On Error Resume Next
Set ws = wb.Worksheets(wsName)
On Error GoTo ClearError
If Not ws Is Nothing Then
If ws.Visible = xlSheetVeryHidden Then
ws.Visible = xlSheetVisible
End If
DeleteSheetNames(dn) = wsName
dn = dn + 1
Set ws = Nothing
End If
Next sn
If dn = 0 Then Exit Sub
If dn < wsnCount Then
ReDim Preserve DeleteSheetNames(0 To dn - 1)
End If
Application.DisplayAlerts = False
wb.Worksheets(DeleteSheetNames).Delete
Application.DisplayAlerts = True
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
What I want to do is, if there is a "1" in column A* then I want the macro to copy the rows, from column B*:L* to a new worksheet, then print the worksheet when it is has gone through the complete range.
If there is no "1" in column A then I just want it to continue to the next row to check. Would love some help?
Sub PrintFlaggedRows()
Const STARTSEARCHROW As Long = 1
Const STARTPRINTROW As Long = 2
Const ENDSEARCHROW As Long = 250
Const STARTCOLUMN As Integer = 1 ' Column A
Const ENDCOLUMN As Integer = 1 ' Column A
Dim oldAlerts As Boolean
Dim oldUpdates As Boolean
Dim destSheet As Worksheet
Dim srcSheet As Worksheet
Dim destRange As Range
Dim i As Long
oldUpdates = Application.ScreenUpdating
Application.ScreenUpdating = False
oldAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
Set srcSheet = Sheets("Estimating & Building Quote")
Set destSheet = Worksheets.Add
Set destRange = destSheet.Cells(STARTPRINTROW, 1)
For i = STARTSEARCHROW To ENDSEARCHROW
If (srcSheet.Cells(i, 1) = 1) _
Or (srcSheet.Cells(i, 1) = "1") Then
srcSheet.Range(Cells(i, STARTCOLUMN), Cells(i, ENDCOLUMN)).Copy
dstRange.PasteSpecial xlPasteValues
dstRange.PasteSpecial xlPasteFormats
Set dstRange = dstRange.Offset(0, 1)
End If
Next i
destSheet.Columns.AutoFit
destSheet.PrintOut
destSheet.Delete
Application.DisplayAlerts = oldAlerts
Application.ScreenUpdating = oldUpdates
End Sub
srcSheet.Range(Cells(i, STARTCOLUMN), Cells(i, ENDCOLUMN)).Copy
Here the unqualified Cells() refers always to the ActiveSheet, which may not be what you want.
Try:
With srcSheet
.Range(.Cells(i, STARTCOLUMN), .Cells(i, ENDCOLUMN)).Copy
End With
If my chart data only equals to one column it gives an error.
Sub RemoveHiddenColumns()
Dim myChart As Chart
Set myChart = Chart4
myChart.Activate 'first activate the chart
Dim i As Integer
For i = 1 To ActiveChart.SeriesCollection.Count 'loop through each series
Dim strText As String, strCol As String, strSht As String, intCol As Integer
strText = Split(ActiveChart.SeriesCollection(i).Formula, ",")(2) 'extract sheet name and column of series
strSht = Split(strText, "!")(0)
strCol = Split(strText, "!")(1) 'get column range of series
Dim wks As Worksheet
Set wks = Sheet2
If wks.Range(strCol).EntireColumn.Hidden = True Then 'if the column is hidden
ActiveChart.SeriesCollection(i).Delete 'remove the series
End If
Next
End Sub
This code successfully removes hidden ROWS from a table. I know that you want to remove columns, but I'm not sure entirely what you're going for so I didn't try and adapt it. You should be able to do that fairly easily.
Sub RhidRow2(ByVal count4 As Long)
Dim count1 As Long 'counters to be used
Dim ws As Worksheet
Dim rngVis As Range
Dim rngDel As Range
Set ws = ActiveSheet
On Error Resume Next
Set rngVis = ws.Range("A2:A" & count4).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngVis Is Nothing Then
ws.Range("Z1").Value = 1
Else
For count1 = count4 To 2 Step -1
If ws.Rows(count1).Hidden = True Then
If rngDel Is Nothing Then
Set rngDel = ws.Rows(count1)
Else
Set rngDel = Union(rngDel, ws.Rows(count1))
End If
End If
Next count1
If Not rngDel Is Nothing Then
Application.DisplayAlerts = False
Intersect(rngDel, rngDel.ListObject.DataBodyRange).Delete 'if row is hidden, delete
Application.DisplayAlerts = True
End If
End If
End Sub