Philcjr
02-07-2009, 06:38 AM
No major issue here, as this code works and is quick. Tried to make a useful Title for future searches to help people.
1) Looking for any code tweaks/best practices to better my coding
2) Looking for some help with a question I have enbedded in the code
I can send the file if need be, but it is 17MB... let me know
Thanks for any help or input... (this file is for my boss, so it needs to be bullet proof/error proof :thumb
Option Explicit
Public WS As Worksheet
Public WS1 As Worksheet
Public LIFSK As Long 'Header Block
Public UVVLS As Long 'Price
Public WERKS As Long 'Alternate Branch
Public VSTEL As Long 'Alternate Branch
Public BERID As Long 'Alternate Branch
Public LIFSP As Long 'Line Blocks
Public LastRow As Long
'=======================================================
Sub Summary()
Dim rCell As Range
Dim C As Long 'Counter for Columns
Dim O As Long 'Counter for All Other Blocks
Dim R As Long 'Counter for Rows
Dim U As Long 'Counter for Line Blocks
Dim V As Long 'Loop Counter
Dim X As Long 'Counter for Header Block
Dim Y As Long 'Counter for Price
Dim Z As Long 'Counter for Alternate Branch
Dim ZZ As Long 'Counter for Alternate Branch
Dim ZZZ As Long 'Counter for Alternate Branch
Dim ZZZZ As Long 'Counter for Alternate Branch - No Dups
Dim FROW As Long, LastCol As Long
Set WS = ThisWorkbook.Worksheets("Pivot Table")
Set WS1 = ThisWorkbook.Worksheets("Summary")
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Promtp for PivotTable Refresh
Dim Prompt As String, uAnswer As VbMsgBoxResult
Prompt = "Do you want to update the PivotTable before calculations? " + vbCrLf + vbCrLf
uAnswer = MsgBox(Prompt, vbQuestion + vbYesNo, "Roll-Up Worksheet Update")
'Update Pivot Table
With WS
.Activate
.Range("A3").Select
If uAnswer = vbYes Then
Application.StatusBar = "Updating Pivot Table, Please Wait..."
.Range("A3").PivotTable.RefreshTable
On Error Resume Next
With .PivotTables("PivotTableI")
.AddFields RowFields:="Sales Doc.", ColumnFields:="Field"
.AddDataField .PivotFields("Change")
.PivotFields("Count of Change2").Orientation = xlHidden
.ColumnGrand = False
.RowGrand = False
End With
.Cells.AutoFit
End If
'Find Columns
Application.StatusBar = "Finding Columns, Please Wait..."
On Error Resume Next
With .Range("A4:IV4")
'========================================================================== =====
'Question: If one of these fields (right below) is missing from the
' Pivot Table, the value = 0, Is there a test I could do prior
' to the "Counting" (just a few lines below)... specifically when
' it comes to the "or" test - (Count for no duplicate Alternate Branch)
'========================================================================== =====
Let FROW = .Find("Sales Doc.", , LookIn:=xlValues, LookAt:=xlWhole).Row
Let LIFSK = .Find("LIFSK", LookIn:=xlValues, LookAt:=xlWhole).Column
Let UVVLS = .Find("UVVLS", LookIn:=xlValues, LookAt:=xlWhole).Column
Let WERKS = .Find("WERKS", LookIn:=xlValues, LookAt:=xlWhole).Column
Let VSTEL = .Find("VSTEL", LookIn:=xlValues, LookAt:=xlWhole).Column
Let BERID = .Find("BERID", LookIn:=xlValues, LookAt:=xlWhole).Column
Let LIFSP = .Find("LIFSP", LookIn:=xlValues, LookAt:=xlWhole).Column
End With
Let LastRow = .Range("A65536").End(xlUp).Row
Let LastCol = .Range("IV" & FROW + 1).End(xlToLeft).Column
'Count for Header Blocks
For Each rCell In .Range(Cells(FROW + 1, LIFSK), Cells(LastRow - 1, LIFSK))
If rCell.Value > 0 Then Let X = X + 1
Next
'Count for Price
For Each rCell In .Range(Cells(FROW + 1, UVVLS), Cells(LastRow - 1, UVVLS))
If rCell.Value > 0 Then Let Y = Y + 1
Next
'Count for Alternate Branch
For Each rCell In .Range(Cells(FROW + 1, WERKS), Cells(LastRow - 1, WERKS))
If rCell.Value > 0 Then Let Z = Z + 1
Next
For Each rCell In .Range(Cells(FROW + 1, VSTEL), Cells(LastRow - 1, VSTEL))
If rCell.Value > 0 Then Let ZZ = ZZ + 1
Next
For Each rCell In .Range(Cells(FROW + 1, BERID), Cells(LastRow - 1, BERID))
If rCell.Value > 0 Then Let ZZZ = ZZZ + 1
Next
'Count for no duplicate Alternate Branch
For V = FROW To LastRow
If .Cells(V, VSTEL).Value > 0 Or _
.Cells(V, WERKS).Value > 0 Or _
.Cells(V, BERID).Value > 0 Then Let ZZZZ = ZZZZ + 1
Next V
'Count for Line Blocks
For Each rCell In .Range(Cells(FROW + 1, LIFSP), Cells(LastRow - 1, LIFSP))
If rCell.Value > 0 Then Let U = U + 1
Next
'Count for all other Blocks
For R = FROW + 1 To LastRow - 1
If .Cells(R, LIFSK).Value > 0 Or _
.Cells(R, UVVLS).Value > 0 Or _
.Cells(R, WERKS).Value > 0 Or _
.Cells(R, VSTEL).Value > 0 Or _
.Cells(R, BERID).Value > 0 Then GoTo NextRow
For C = 2 To LastCol
For Each rCell In .Range(Cells(R, C), Cells(R, LastCol))
If rCell.Value > 0 Then
Let O = O + 1
GoTo NextRow
End If
Next
NextCol:
Next C
NextRow:
Next R
End With
'Apply Values and Formats
With WS1
.Range("D5:F10").ClearContents
.Range("B14:D15").ClearContents
.Range("D5").Value = Format(X, "#,###")
.Range("D6").Value = Format(Y, "#,###")
.Range("D7").Value = Format(Z, "#,###")
.Range("D8").Value = Format(ZZ, "#,###")
.Range("D9").Value = Format(ZZZ, "#,###")
.Range("D10").Value = Format(U, "#,###")
.Range("B14").Value = Format(LastRow - FROW + 1 - O, "#,###")
.Range("B15").Value = Format(O, "#,###")
.Range("E5").Value = Format(X, "#,###")
.Range("E6").Value = Format(Y, "#,###")
.Range("E7").Value = Format(ZZZZ, "#,###")
.Range("E10").Value = Format(U, "#,###")
.Range("F3").Value = LastRow - 1 - FROW
.Range("F5").Value = Format(X / .Range("F2").Value, "###.##%")
.Range("F6").Value = Format(Y / .Range("F2").Value, "###.##%")
.Range("F7").Value = Format(ZZZZ / .Range("F2").Value, "###.##%")
.Range("F10").Value = Format(U / .Range("F2").Value, "###.##%")
.Range("C14").Value = Format(.Range("B14").Value / .Range("F2").Value, "###.##%")
.Range("C15").Value = Format(O / .Range("F2").Value, "###.##%")
.Range("D14").Value = Format(.Range("B14").Value / .Range("F3").Value, "###.##%")
.Range("D15").Value = Format(O / .Range("F3").Value, "###.##%")
.Activate
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = ""
End With
ActiveWorkbook.ShowPivotTableFieldList = False
MsgBox "All Done!", vbInformation
WS1.Range("A1").Select
End Sub
'=======================================================
Sub SummaryII()
Dim Customer As Long, X As Long
Set WS = ThisWorkbook.Worksheets("Pivot Table II")
Set WS1 = ThisWorkbook.Worksheets("Summary II")
Let LastRow = WS1.Range("C65536").End(xlUp).Row
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
WS1.Range("D3:I" & LastRow).ClearContents
'Update the Pivot Table
With WS
On Error Resume Next
Application.StatusBar = "Updating Pivot Table, Please Wait..."
With .PivotTables("PivotTableII")
.AddFields RowFields:="Sold-to pt", ColumnFields:="Field"
.AddDataField .PivotFields("Change")
.PivotFields("Count of Change2").Orientation = xlHidden
.ColumnGrand = False
.RowGrand = False
End With
.Cells.AutoFit
'Find Columns
With .Range("A4:IV4")
Let LIFSK = .Find("LIFSK", LookIn:=xlValues, LookAt:=xlWhole).Column
Let UVVLS = .Find("UVVLS", LookIn:=xlValues, LookAt:=xlWhole).Column
Let WERKS = .Find("WERKS", LookIn:=xlValues, LookAt:=xlWhole).Column
Let VSTEL = .Find("VSTEL", LookIn:=xlValues, LookAt:=xlWhole).Column
Let BERID = .Find("BERID", LookIn:=xlValues, LookAt:=xlWhole).Column
Let LIFSP = .Find("LIFSP", LookIn:=xlValues, LookAt:=xlWhole).Column
End With
'Get Values
For X = 5 To LastRow
If WS1.Range("C" & X).Value = "" Then GoTo NextCustomer
On Error Resume Next
Let Customer = .Range("A4:A" & LastRow).Find(WS1.Cells(X, 3).Text, LookIn:=xlValues, LookAt:=xlWhole).Row
On Error GoTo 0
If Customer = 0 Then GoTo NextCustomer
WS1.Cells(X, 4).Value = .Cells(Customer, LIFSK).Value
WS1.Cells(X, 5).Value = .Cells(Customer, UVVLS).Value
WS1.Cells(X, 6).Value = .Cells(Customer, WERKS).Value
WS1.Cells(X, 7).Value = .Cells(Customer, VSTEL).Value
WS1.Cells(X, 8).Value = .Cells(Customer, BERID).Value
WS1.Cells(X, 9).Value = .Cells(Customer, LIFSP).Value
NextCustomer:
Next X
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = ""
End With
ActiveWorkbook.ShowPivotTableFieldList = False
MsgBox "All Done!", vbInformation
'Set FreezePanes
With WS
.Activate
.Range("B5").Select
With ActiveWindow
.FreezePanes = True
.ScrollColumn = 1
.ScrollRow = 1
End With
End With
With WS1
.Activate
.Range("A1").Select
End With
End Sub
1) Looking for any code tweaks/best practices to better my coding
2) Looking for some help with a question I have enbedded in the code
I can send the file if need be, but it is 17MB... let me know
Thanks for any help or input... (this file is for my boss, so it needs to be bullet proof/error proof :thumb
Option Explicit
Public WS As Worksheet
Public WS1 As Worksheet
Public LIFSK As Long 'Header Block
Public UVVLS As Long 'Price
Public WERKS As Long 'Alternate Branch
Public VSTEL As Long 'Alternate Branch
Public BERID As Long 'Alternate Branch
Public LIFSP As Long 'Line Blocks
Public LastRow As Long
'=======================================================
Sub Summary()
Dim rCell As Range
Dim C As Long 'Counter for Columns
Dim O As Long 'Counter for All Other Blocks
Dim R As Long 'Counter for Rows
Dim U As Long 'Counter for Line Blocks
Dim V As Long 'Loop Counter
Dim X As Long 'Counter for Header Block
Dim Y As Long 'Counter for Price
Dim Z As Long 'Counter for Alternate Branch
Dim ZZ As Long 'Counter for Alternate Branch
Dim ZZZ As Long 'Counter for Alternate Branch
Dim ZZZZ As Long 'Counter for Alternate Branch - No Dups
Dim FROW As Long, LastCol As Long
Set WS = ThisWorkbook.Worksheets("Pivot Table")
Set WS1 = ThisWorkbook.Worksheets("Summary")
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Promtp for PivotTable Refresh
Dim Prompt As String, uAnswer As VbMsgBoxResult
Prompt = "Do you want to update the PivotTable before calculations? " + vbCrLf + vbCrLf
uAnswer = MsgBox(Prompt, vbQuestion + vbYesNo, "Roll-Up Worksheet Update")
'Update Pivot Table
With WS
.Activate
.Range("A3").Select
If uAnswer = vbYes Then
Application.StatusBar = "Updating Pivot Table, Please Wait..."
.Range("A3").PivotTable.RefreshTable
On Error Resume Next
With .PivotTables("PivotTableI")
.AddFields RowFields:="Sales Doc.", ColumnFields:="Field"
.AddDataField .PivotFields("Change")
.PivotFields("Count of Change2").Orientation = xlHidden
.ColumnGrand = False
.RowGrand = False
End With
.Cells.AutoFit
End If
'Find Columns
Application.StatusBar = "Finding Columns, Please Wait..."
On Error Resume Next
With .Range("A4:IV4")
'========================================================================== =====
'Question: If one of these fields (right below) is missing from the
' Pivot Table, the value = 0, Is there a test I could do prior
' to the "Counting" (just a few lines below)... specifically when
' it comes to the "or" test - (Count for no duplicate Alternate Branch)
'========================================================================== =====
Let FROW = .Find("Sales Doc.", , LookIn:=xlValues, LookAt:=xlWhole).Row
Let LIFSK = .Find("LIFSK", LookIn:=xlValues, LookAt:=xlWhole).Column
Let UVVLS = .Find("UVVLS", LookIn:=xlValues, LookAt:=xlWhole).Column
Let WERKS = .Find("WERKS", LookIn:=xlValues, LookAt:=xlWhole).Column
Let VSTEL = .Find("VSTEL", LookIn:=xlValues, LookAt:=xlWhole).Column
Let BERID = .Find("BERID", LookIn:=xlValues, LookAt:=xlWhole).Column
Let LIFSP = .Find("LIFSP", LookIn:=xlValues, LookAt:=xlWhole).Column
End With
Let LastRow = .Range("A65536").End(xlUp).Row
Let LastCol = .Range("IV" & FROW + 1).End(xlToLeft).Column
'Count for Header Blocks
For Each rCell In .Range(Cells(FROW + 1, LIFSK), Cells(LastRow - 1, LIFSK))
If rCell.Value > 0 Then Let X = X + 1
Next
'Count for Price
For Each rCell In .Range(Cells(FROW + 1, UVVLS), Cells(LastRow - 1, UVVLS))
If rCell.Value > 0 Then Let Y = Y + 1
Next
'Count for Alternate Branch
For Each rCell In .Range(Cells(FROW + 1, WERKS), Cells(LastRow - 1, WERKS))
If rCell.Value > 0 Then Let Z = Z + 1
Next
For Each rCell In .Range(Cells(FROW + 1, VSTEL), Cells(LastRow - 1, VSTEL))
If rCell.Value > 0 Then Let ZZ = ZZ + 1
Next
For Each rCell In .Range(Cells(FROW + 1, BERID), Cells(LastRow - 1, BERID))
If rCell.Value > 0 Then Let ZZZ = ZZZ + 1
Next
'Count for no duplicate Alternate Branch
For V = FROW To LastRow
If .Cells(V, VSTEL).Value > 0 Or _
.Cells(V, WERKS).Value > 0 Or _
.Cells(V, BERID).Value > 0 Then Let ZZZZ = ZZZZ + 1
Next V
'Count for Line Blocks
For Each rCell In .Range(Cells(FROW + 1, LIFSP), Cells(LastRow - 1, LIFSP))
If rCell.Value > 0 Then Let U = U + 1
Next
'Count for all other Blocks
For R = FROW + 1 To LastRow - 1
If .Cells(R, LIFSK).Value > 0 Or _
.Cells(R, UVVLS).Value > 0 Or _
.Cells(R, WERKS).Value > 0 Or _
.Cells(R, VSTEL).Value > 0 Or _
.Cells(R, BERID).Value > 0 Then GoTo NextRow
For C = 2 To LastCol
For Each rCell In .Range(Cells(R, C), Cells(R, LastCol))
If rCell.Value > 0 Then
Let O = O + 1
GoTo NextRow
End If
Next
NextCol:
Next C
NextRow:
Next R
End With
'Apply Values and Formats
With WS1
.Range("D5:F10").ClearContents
.Range("B14:D15").ClearContents
.Range("D5").Value = Format(X, "#,###")
.Range("D6").Value = Format(Y, "#,###")
.Range("D7").Value = Format(Z, "#,###")
.Range("D8").Value = Format(ZZ, "#,###")
.Range("D9").Value = Format(ZZZ, "#,###")
.Range("D10").Value = Format(U, "#,###")
.Range("B14").Value = Format(LastRow - FROW + 1 - O, "#,###")
.Range("B15").Value = Format(O, "#,###")
.Range("E5").Value = Format(X, "#,###")
.Range("E6").Value = Format(Y, "#,###")
.Range("E7").Value = Format(ZZZZ, "#,###")
.Range("E10").Value = Format(U, "#,###")
.Range("F3").Value = LastRow - 1 - FROW
.Range("F5").Value = Format(X / .Range("F2").Value, "###.##%")
.Range("F6").Value = Format(Y / .Range("F2").Value, "###.##%")
.Range("F7").Value = Format(ZZZZ / .Range("F2").Value, "###.##%")
.Range("F10").Value = Format(U / .Range("F2").Value, "###.##%")
.Range("C14").Value = Format(.Range("B14").Value / .Range("F2").Value, "###.##%")
.Range("C15").Value = Format(O / .Range("F2").Value, "###.##%")
.Range("D14").Value = Format(.Range("B14").Value / .Range("F3").Value, "###.##%")
.Range("D15").Value = Format(O / .Range("F3").Value, "###.##%")
.Activate
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = ""
End With
ActiveWorkbook.ShowPivotTableFieldList = False
MsgBox "All Done!", vbInformation
WS1.Range("A1").Select
End Sub
'=======================================================
Sub SummaryII()
Dim Customer As Long, X As Long
Set WS = ThisWorkbook.Worksheets("Pivot Table II")
Set WS1 = ThisWorkbook.Worksheets("Summary II")
Let LastRow = WS1.Range("C65536").End(xlUp).Row
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
WS1.Range("D3:I" & LastRow).ClearContents
'Update the Pivot Table
With WS
On Error Resume Next
Application.StatusBar = "Updating Pivot Table, Please Wait..."
With .PivotTables("PivotTableII")
.AddFields RowFields:="Sold-to pt", ColumnFields:="Field"
.AddDataField .PivotFields("Change")
.PivotFields("Count of Change2").Orientation = xlHidden
.ColumnGrand = False
.RowGrand = False
End With
.Cells.AutoFit
'Find Columns
With .Range("A4:IV4")
Let LIFSK = .Find("LIFSK", LookIn:=xlValues, LookAt:=xlWhole).Column
Let UVVLS = .Find("UVVLS", LookIn:=xlValues, LookAt:=xlWhole).Column
Let WERKS = .Find("WERKS", LookIn:=xlValues, LookAt:=xlWhole).Column
Let VSTEL = .Find("VSTEL", LookIn:=xlValues, LookAt:=xlWhole).Column
Let BERID = .Find("BERID", LookIn:=xlValues, LookAt:=xlWhole).Column
Let LIFSP = .Find("LIFSP", LookIn:=xlValues, LookAt:=xlWhole).Column
End With
'Get Values
For X = 5 To LastRow
If WS1.Range("C" & X).Value = "" Then GoTo NextCustomer
On Error Resume Next
Let Customer = .Range("A4:A" & LastRow).Find(WS1.Cells(X, 3).Text, LookIn:=xlValues, LookAt:=xlWhole).Row
On Error GoTo 0
If Customer = 0 Then GoTo NextCustomer
WS1.Cells(X, 4).Value = .Cells(Customer, LIFSK).Value
WS1.Cells(X, 5).Value = .Cells(Customer, UVVLS).Value
WS1.Cells(X, 6).Value = .Cells(Customer, WERKS).Value
WS1.Cells(X, 7).Value = .Cells(Customer, VSTEL).Value
WS1.Cells(X, 8).Value = .Cells(Customer, BERID).Value
WS1.Cells(X, 9).Value = .Cells(Customer, LIFSP).Value
NextCustomer:
Next X
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = ""
End With
ActiveWorkbook.ShowPivotTableFieldList = False
MsgBox "All Done!", vbInformation
'Set FreezePanes
With WS
.Activate
.Range("B5").Select
With ActiveWindow
.FreezePanes = True
.ScrollColumn = 1
.ScrollRow = 1
End With
End With
With WS1
.Activate
.Range("A1").Select
End With
End Sub