PDA

View Full Version : Macro auto filter to create report pasting hidden rows. Help



DBR138
07-12-2018, 03:22 PM
I have been working on this macro for ages and have learned a lot but now I am completely stuck. I have my source data filtering correctly at this point but when it pastes the data into the report it is including the hidden lines and negating the filter. I assume this has something to do with my range but I can't figure it out. Pasting the code below. If anyone could help me get past this I would be forever grateful. If you need any additional information I will provide it as soon as possible.


Public Sub CreatePassOn()


Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Const filterField1 As Long = 8
Const filterField2 As Long = 27
Const criterion1 As String = "QC-Completed"
Const criterion2 As String = vbNullString
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Data")
Set wsTarget = wb.Worksheets("Pass On")
Dim lastRowSource As Long
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
Dim lastColumnSource As Long
lastColumnSource = wsSource.Range("A1").SpecialCells(xlCellTypeLastCell).Column
Dim filterRange As Range
Set filterRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRowSource, lastColumnSource))
wsSource.AutoFilterMode = False
Dim dataArray As Variant
With filterRange
.AutoFilter
.AutoFilter Field:=filterField1, Criteria1:="<>" & criterion1, Operator:=xlFilterValues
.AutoFilter Field:=filterField2, Criteria1:=criterion2
With wsSource.AutoFilter.Range
dataArray = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'exclude header
End With
End With
Application.CutCopyMode = False 'Clear clipboard
Dim columnsToKeep() As Variant
columnsToKeep = Array(13, 36, 2, 3, 24, 8, 12) 'determine output columns to keep and their order
Dim currentRow As Long
Dim currentColumn As Long
Dim resultArray() As Variant
ReDim resultArray(1 To UBound(dataArray, 1), 1 To UBound(columnsToKeep) + 1)
Dim columnCounter As Long
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
columnCounter = 0
For currentColumn = LBound(columnsToKeep) To UBound(columnsToKeep)
columnCounter = columnCounter + 1
resultArray(currentRow, columnCounter) = dataArray(currentRow, columnsToKeep(currentColumn))
Next currentColumn
Next currentRow
wsTarget.Range("A2").Resize(UBound(resultArray, 1), UBound(resultArray, 2)) = resultArray
MsgBox "Pass on creation succesful! Please update your comments and print."
End Sub

DBR138
07-13-2018, 01:00 PM
I suspect that the problem lies within the following smaller section of code. Perhaps I need to redefine my range after applying the filter instead of using dataArray again?


With filterRange
.AutoFilter
.AutoFilter Field:=filterField1, Criteria1:="<>" & criterion1, Operator:=xlFilterValues
.AutoFilter Field:=filterField2, Criteria1:=criterion2

With wsSource.AutoFilter.Range
dataArray = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'exclude header
End With
End With
Application.CutCopyMode = False 'Clear clipboard
Dim columnsToKeep() As Variant
columnsToKeep = Array(13, 36, 2, 3, 24, 8, 12) 'determine output columns to keep and their order
Dim currentRow As Long
Dim currentColumn As Long
Dim resultArray() As Variant
ReDim resultArray(1 To UBound(dataArray, 1), 1 To UBound(columnsToKeep) + 1)
Dim columnCounter As Long
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
columnCounter = 0
For currentColumn = LBound(columnsToKeep) To UBound(columnsToKeep)
columnCounter = columnCounter + 1
resultArray(currentRow, columnCounter) = dataArray(currentRow, columnsToKeep(currentColumn))
Next currentColumn
Next currentRow
wsTarget.Range("A2").Resize(UBound(resultArray, 1), UBound(resultArray, 2)) = resultArray

p45cal
07-13-2018, 03:57 PM
try (untested):
Public Sub CreatePassOn()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim ResultRowCount As Long
Const filterField1 As Long = 8
Const filterField2 As Long = 27
Const criterion1 As String = "QC-Completed"
Const criterion2 As String = vbNullString
Dim columnsToKeep() As Variant
Dim currentRow As Long
Dim currentColumn As Long
Dim resultArray() As Variant
Dim columnCounter As Long

Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Data")
Set wsTarget = wb.Worksheets("Pass On")
Dim lastRowSource As Long
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
Dim lastColumnSource As Long
lastColumnSource = wsSource.Range("A1").SpecialCells(xlCellTypeLastCell).Column
Dim filterRange As Range
Set filterRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRowSource, lastColumnSource))
wsSource.AutoFilterMode = False
Dim dataArray As Variant
With filterRange
' .AutoFilter
' .AutoFilter Field:=filterField1, Criteria1:="<>" & criterion1, Operator:=xlFilterValues
' .AutoFilter Field:=filterField2, Criteria1:=criterion2
' With wsSource.AutoFilter.Range
dataArray = .Offset(1).Resize(.Rows.Count - 1) 'exclude header
' End With
End With
'Application.CutCopyMode = False 'Clear clipboard
columnsToKeep = Array(13, 36, 2, 3, 24, 8, 12) 'determine output columns to keep and their order
ReDim resultArray(1 To UBound(dataArray, 1), 1 To UBound(columnsToKeep) + 1)
ResultRowCount = 0
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
If dataArray(currentRow, filterField1) <> criterion1 And dataArray(currentRow, filterField2) = criterion2 Then
ResultRowCount = ResultRowCount + 1
columnCounter = 0
For currentColumn = LBound(columnsToKeep) To UBound(columnsToKeep)
columnCounter = columnCounter + 1
resultArray(ResultRowCount, columnCounter) = dataArray(currentRow, columnsToKeep(currentColumn))
Next currentColumn
End If
Next currentRow
wsTarget.Range("A2").Resize(ResultRowCount, UBound(resultArray, 2)) = resultArray
MsgBox "Pass on creation succesful! Please update your comments and print."
End Sub
When you assign values to dataArray it ignores that rows are hidden. So I ditched the Autofilter and did that in code instead.

Using Advanced Filter in VBA would probably be easier and shorter.

p45cal
07-13-2018, 05:52 PM
With advanced filter:
Sub CreatePassOnAdvFilter()
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Dim columnsToKeep() As Variant, colm As Long, v, Destn As Range, CritRangeTopLeft As Range, CritRangeBottomRight As Range, CritRange As Range
Dim lastColumnSource As Long, lastRowSource As Long, filterRange As Range
Const filterField1 As Long = 8
Const filterField2 As Long = 27
Const criterion1 As String = "QC-Completed"
Const criterion2 As String = vbNullString

Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Data")
Set wsTarget = wb.Worksheets("Pass On")
On Error Resume Next: wsSource.ShowAllData: On Error GoTo 0
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
lastColumnSource = wsSource.Range("A1").SpecialCells(xlCellTypeLastCell).Column
Set filterRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRowSource, lastColumnSource))
columnsToKeep = Array(13, 36, 2, 3, 24, 8, 12) 'determine output columns to keep and their order
'this next section puts the headers on row 1 of the Pass On sheet:
colm = 0
For Each v In columnsToKeep
colm = colm + 1
wsTarget.Cells(1, colm).Value = wsSource.Cells(1, v)
Next v

Set Destn = Range(wsTarget.Cells(1, 1), wsTarget.Cells(1, colm)) 'for the advanced filter later.

'Now set up Criteria range for Advanced Filter:
colm = colm + 2
wsTarget.Cells(1, colm).Value = wsSource.Cells(1, filterField1)
Set CritRangeTopLeft = wsTarget.Cells(1, colm)
wsTarget.Cells(2, colm).Value = "<>" & criterion1
colm = colm + 1
wsTarget.Cells(1, colm).Value = wsSource.Cells(1, filterField2)
wsTarget.Cells(2, colm).Value = "=" & criterion2
Set CritRangeBottomRight = wsTarget.Cells(2, colm)
Set CritRange = Range(CritRangeTopLeft, CritRangeBottomRight)

'Now do the filtering:
filterRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CritRange, CopyToRange:=Destn, Unique:=False

'tidy up:
CritRange.Clear
End Sub

p45cal
07-13-2018, 06:06 PM
Before anyone else thinks of spending significant time on this, this question has been cross posted elsewhere.

DBR138
07-17-2018, 11:14 AM
This is so much cleaner. I had no idea. Thank you very much! I have a lot to play with now.




With advanced filter:
Sub CreatePassOnAdvFilter()
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Dim columnsToKeep() As Variant, colm As Long, v, Destn As Range, CritRangeTopLeft As Range, CritRangeBottomRight As Range, CritRange As Range
Dim lastColumnSource As Long, lastRowSource As Long, filterRange As Range
Const filterField1 As Long = 8
Const filterField2 As Long = 27
Const criterion1 As String = "QC-Completed"
Const criterion2 As String = vbNullString

Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Data")
Set wsTarget = wb.Worksheets("Pass On")
On Error Resume Next: wsSource.ShowAllData: On Error GoTo 0
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
lastColumnSource = wsSource.Range("A1").SpecialCells(xlCellTypeLastCell).Column
Set filterRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRowSource, lastColumnSource))
columnsToKeep = Array(13, 36, 2, 3, 24, 8, 12) 'determine output columns to keep and their order
'this next section puts the headers on row 1 of the Pass On sheet:
colm = 0
For Each v In columnsToKeep
colm = colm + 1
wsTarget.Cells(1, colm).Value = wsSource.Cells(1, v)
Next v

Set Destn = Range(wsTarget.Cells(1, 1), wsTarget.Cells(1, colm)) 'for the advanced filter later.

'Now set up Criteria range for Advanced Filter:
colm = colm + 2
wsTarget.Cells(1, colm).Value = wsSource.Cells(1, filterField1)
Set CritRangeTopLeft = wsTarget.Cells(1, colm)
wsTarget.Cells(2, colm).Value = "<>" & criterion1
colm = colm + 1
wsTarget.Cells(1, colm).Value = wsSource.Cells(1, filterField2)
wsTarget.Cells(2, colm).Value = "=" & criterion2
Set CritRangeBottomRight = wsTarget.Cells(2, colm)
Set CritRange = Range(CritRangeTopLeft, CritRangeBottomRight)

'Now do the filtering:
filterRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CritRange, CopyToRange:=Destn, Unique:=False

'tidy up:
CritRange.Clear
End Sub