VBA codeperforming two functions, check column then count all columns & create tables

[johnnyjeb]

Hi everyone,


I don't think this should be too complicated. I would be super grateful if someone could provide some VBA code that runs in the following steps:


Step 1:
1) Delete all rows that do not have the word "Yes" in column B.
2) Delete all rows that left column ABC OR ABD blank.


Step 2:
1)Perform a count function for each different response in each column of data from column B to column BCR
2)Create tables for each column of data showing the distribution of responses with both the number of each unique response and percentage of total responses for that column


SINCERELY APPRECIATED.


Thank you!


V

[p45cal]

I don't think this should be too complicated.
It's by no means trivial! Columns B to BCR is some 1500 tables.
In the attached, your workbook with a macro blah in it. Make sure the sheet you want to process is the active sheet before running the blah macro.
It will first make a copy of that sheet (to preserve it) and work on the copy.
Then it deletes rows according to your Step 1
Then it adds another sheet and makes some tables.
Takes 1 to 2 minutes here.

The code in blah is:

Sub blah()
Application.ScreenUpdating = False
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Set SceSht = ActiveSheet
Set SceDta = SceSht.Range("B1").CurrentRegion
On Error Resume Next: SceSht.ShowAllData: On Error GoTo 0
FieldNos = Array(2, 731, 732) 'column numbers
Crits = Array("<>Yes", "=", "=") 'column numbers
SceDta.AutoFilter
Set databody = Intersect(SceDta, SceDta.Offset(1))

For i = LBound(Crits) To UBound(Crits)
SceDta.AutoFilter Field:=FieldNos(i), Criteria1:=Crits(i) ', Operator:=xlAnd
Set RngToDelete = Nothing
On Error Resume Next: Set RngToDelete = databody.SpecialCells(xlCellTypeVisible): On Error GoTo 0
If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete Shift:=xlUp
On Error Resume Next: SceSht.ShowAllData: On Error GoTo 0
Next i
SceDta.AutoFilter

Set NewSht1 = Sheets.Add(After:=Sheets(Sheets.Count))
Set Destn = NewSht1.Range("A2")
Set PivotSht = Sheets.Add
Set PC = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=SceDta)
Set pt = PC.CreatePivotTable(TableDestination:=PivotSht.Range("A3"))
With pt
.ColumnGrand = False
.PageFieldOrder = 2
.RowGrand = False
.DisplayMemberPropertyTooltips = False
.ShowValuesRow = False
.RowAxisLayout xlTabularRow
.HasAutoFormat = False
.AddDataField .PivotFields("ExternalReference"), "Count", xlCount
.AddDataField .PivotFields("ExternalReference"), "%", xlCount
With .PivotFields("%")
.Calculation = xlPercentOfColumn
.NumberFormat = "0.00%"
End With
.ColumnRange.HorizontalAlignment = xlCenter
Set pfs = .PivotFields
For i = 2 To 1448
.AddFields RowFields:=pfs(i).Name
Destn.Resize(.TableRange1.Rows.Count, .TableRange1.Columns.Count).Value = .TableRange1.Value
.TableRange1.Copy
Destn.PasteSpecial xlPasteFormats
Set Destn = Destn.Offset(.TableRange1.Rows.Count + 2)
pfs(i).Orientation = xlHidden
Next i
End With
Application.DisplayAlerts = False: PivotSht.Delete: Application.DisplayAlerts = True
NewSht1.Columns("A").ColumnWidth = 50
Application.ScreenUpdating = True
End Sub

[johnnyjeb]

p45cal, first of all THANK YOU for your assistance.
I'm running into this error when running the code.

"Run Time Error '13'":
Type mismatch

when i press debug it sends me to this line:
Set PC = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=SceDta)

advice?

THANK YOU AGAIN!!! :)

V

[p45cal]

What version of Excel?

[p45cal]

a guess, try:
Sub blah()
Application.ScreenUpdating = False
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Set SceSht = ActiveSheet
Set SceDta = SceSht.Range("B1").CurrentRegion
StrSceDta = SceDta.Address(ReferenceStyle:=xlR1C1, external:=True)

On Error Resume Next: SceSht.ShowAllData: On Error GoTo 0
FieldNos = Array(2, 731, 732) 'column numbers
Crits = Array("<>Yes", "=", "=") 'column numbers
SceDta.AutoFilter
Set databody = Intersect(SceDta, SceDta.Offset(1))

For i = LBound(Crits) To UBound(Crits)
SceDta.AutoFilter Field:=FieldNos(i), Criteria1:=Crits(i) ', Operator:=xlAnd
Set RngToDelete = Nothing
On Error Resume Next: Set RngToDelete = databody.SpecialCells(xlCellTypeVisible): On Error GoTo 0
If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete Shift:=xlUp
On Error Resume Next: SceSht.ShowAllData: On Error GoTo 0
Next i
SceDta.AutoFilter

Set NewSht1 = Sheets.Add(After:=Sheets(Sheets.Count))
Set Destn = NewSht1.Range("A2")
Set PivotSht = Sheets.Add
Set PC = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=StrSceDta)
Set pt = PC.CreatePivotTable(TableDestination:=PivotSht.Range("A3"))
With pt
.ColumnGrand = False
.PageFieldOrder = 2
.RowGrand = False
.DisplayMemberPropertyTooltips = False
.ShowValuesRow = False
.RowAxisLayout xlTabularRow
.HasAutoFormat = False
.AddDataField .PivotFields("ExternalReference"), "Count", xlCount
.AddDataField .PivotFields("ExternalReference"), "%", xlCount
With .PivotFields("%")
.Calculation = xlPercentOfColumn
.NumberFormat = "0.00%"
End With
.ColumnRange.HorizontalAlignment = xlCenter
Set pfs = .PivotFields
For i = 2 To 1448
.AddFields RowFields:=pfs(i).Name
Destn.Resize(.TableRange1.Rows.Count, .TableRange1.Columns.Count).Value = .TableRange1.Value
.TableRange1.Copy
Destn.PasteSpecial xlPasteFormats
Set Destn = Destn.Offset(.TableRange1.Rows.Count + 2)
pfs(i).Orientation = xlHidden
Next i
End With
Application.DisplayAlerts = False: PivotSht.Delete: Application.DisplayAlerts = True
NewSht1.Columns("A").ColumnWidth = 50
Application.ScreenUpdating = True
End Sub

[johnnyjeb]

Hey!

Wow Thank you so much p45cal!!
Quick question --- would you be able to tweak the code so that in sheet 2 the table headers aren't what is shown in row 1 but row 2 instead(since these are the actual questions)

Thanks again!

V

[p45cal]

You deleted row 2 in step 1.
There are many duplicate questions, however:

Sub blah2()
Application.ScreenUpdating = False
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Set SceSht = ActiveSheet
SceSht.Rows(1).Cut
SceSht.Rows(3).Insert Shift:=xlDown

Set SceDta = SceSht.Range("B1").CurrentRegion
Set SceDta = Intersect(SceDta, SceDta.Offset(1))
StrSceDta = SceDta.Address(ReferenceStyle:=xlR1C1, external:=True)

On Error Resume Next: SceSht.ShowAllData: On Error GoTo 0
FieldNos = Array(2, 731, 732) 'column numbers
Crits = Array("<>Yes", "=", "=") 'column numbers
SceDta.AutoFilter
Set databody = Intersect(SceDta, SceDta.Offset(1))

For i = LBound(Crits) To UBound(Crits)
SceDta.AutoFilter Field:=FieldNos(i), Criteria1:=Crits(i) ', Operator:=xlAnd
Set RngToDelete = Nothing
On Error Resume Next: Set RngToDelete = databody.SpecialCells(xlCellTypeVisible): On Error GoTo 0
If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete Shift:=xlUp
On Error Resume Next: SceSht.ShowAllData: On Error GoTo 0
Next i
SceDta.AutoFilter

Set NewSht1 = Sheets.Add(After:=Sheets(Sheets.Count))
Set destn = NewSht1.Range("A2")
Set PivotSht = Sheets.Add
Set PC = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=StrSceDta)
Set pt = PC.CreatePivotTable(TableDestination:=PivotSht.Range("A3"))
With pt
.ColumnGrand = False
.PageFieldOrder = 2
.RowGrand = False
.DisplayMemberPropertyTooltips = False
.ShowValuesRow = False
.RowAxisLayout xlTabularRow
.HasAutoFormat = False
.AddDataField .PivotFields("ExternalReference"), "Count", xlCount
.AddDataField .PivotFields("ExternalReference"), "%", xlCount
With .PivotFields("%")
.Calculation = xlPercentOfColumn
.NumberFormat = "0.00%"
End With
.ColumnRange.HorizontalAlignment = xlCenter
Set pfs = .PivotFields
For i = 2 To 1448
.AddFields RowFields:=pfs(i).Name
destn.WrapText = False
destn.Resize(.TableRange1.Rows.Count, .TableRange1.Columns.Count).Value = .TableRange1.Value
.TableRange1.Copy
destn.PasteSpecial xlPasteFormats
destn.Value = SceSht.Cells(1, i).Value
destn.WrapText = False
Set destn = destn.Offset(.TableRange1.Rows.Count + 2)
pfs(i).Orientation = xlHidden
Next i
End With
Application.DisplayAlerts = False: PivotSht.Delete: Application.DisplayAlerts = True
NewSht1.Columns("A").ColumnWidth = 50
Application.ScreenUpdating = True
End Sub