I work with OLAP Cubes and have created code on several occasions for different purposes but now I would like to combine several functions, how do I succeed with that?
This is what I need help putting together. I am a real beginner and have solved most things through google before but now I cant find anything that I understand or that helps me.
1)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$5" Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
Dim pt As PivotTable
Dim ws As Worksheet
For Each ws In Worksheets
For Each pt In ws.PivotTables
pt.PivotFields("[Casino].[Casino].[Casino]").CurrentPageName = "[Casino].[Casino].&[" & Format(ActiveSheet.Cells(5, 1).Value, "") & "]"
pt.PivotFields
Next pt
Next ws
GoTo Sluta
Fel:
MsgBox "Något gick fel :("
Sluta:
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$3" Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
Dim pt As PivotTable
Dim ws As Worksheet
For Each ws In Worksheets
For Each pt In ws.PivotTables
pt.PivotFields("[Date].[Month Number].[Month Number]").CurrentPageName = "[Date].[Month Number].&[" & Format(ActiveSheet.Cells(3, 1).Value, "") & "]"
pt.PivotFields
Next pt
Next ws
GoTo Sluta
Fel:
MsgBox "Något gick fel :("
Sluta:
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$2" Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
Dim pt As PivotTable
Dim ws As Worksheet
For Each ws In Worksheets
For Each pt In ws.PivotTables
pt.PivotFields("[Date].[Year].[Year]").CurrentPageName = "[Date].[Year].&[" & Format(ActiveSheet.Cells(2, 1).Value, "") & "]"
pt.PivotFields
Next pt
Next ws
GoTo Sluta
Fel:
MsgBox "Något gick fel :("
Sluta:
Application.ScreenUpdating = True
End Sub
Write everything in one procedure and do not repeat your code.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim PivFld As String
Dim PageName As String
On Error GoTo Fel
Application.ScreenUpdating = False
Select Case Target.Address
Case "$A$5"
PivFld = "[Casino].[Casino].[Casino]"
PageName = "[Casino].[Casino].&[" & Format(ActiveSheet.Cells(5, 1).Value, "") & "]"
Case "$A$3"
PivFld = "[Date].[Month Number].[Month Number]"
PageName = "[Date].[Month Number].&[" & Format(ActiveSheet.Cells(3, 1).Value, "") & "]"
Case "$A$2"
PivFld = "[Date].[Year].[Year]"
PageName = "[Date].[Year].&[" & Format(ActiveSheet.Cells(2, 1).Value, "") & "]"
Case Else
Exit Sub
End Select
Dim ws As Worksheet
For Each ws In Worksheets
Dim pt As PivotTable
For Each pt In ws.PivotTables
pt.PivotFields(PivFld).CurrentPageName = PageName
pt.PivotFields
Next pt
Next ws
GoTo Sluta
Fel:
MsgBox "Något gick fel :("
Sluta:
Application.ScreenUpdating = True
End Sub
Note that On Error Resume Next hides all error messages and you will never know if something goes wrong. Instead use On Error GoTo Fel and at least you get informed that something went wrong.
you can combine all the ones into a single code and use if-statements for the differences:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fields As String
Dim pageName as String
If Target.Address = "$A$5" Then fields="[Casino].[Casino].[Casino]": pageName = "[Casino].[Casino].&["
If Target.Address = "$A$3" Then fields="[Date].[Month Number].[Month Number]": pageName = "[Date].[Month Number].&["
If Target.Address = "$A$2" Then fields="[Date].[Year].[Year]": pageName = "[Date].[Year].&["
If fields = "" Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
Dim pt As PivotTable
Dim ws As Worksheet
For Each ws In Worksheets
For Each pt In ws.PivotTables
pt.PivotFields(fields).CurrentPageName = pageName & Format(Target.Value, "") & "]"
pt.PivotFields
Next pt
Next ws
GoTo Sluta
Fel:
MsgBox "Något gick fel :("
Sluta:
Application.ScreenUpdating = True
End Sub
Also adding variables fields and pageName to simplify.
Related
I am fairly new to VBA and struglling with the idea on how to merge both of these subs into one, as i need to enable dynamic filters for two separate Pivots.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
On Error Resume Next
If Intersect(Target, Range("L3:L4")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Summary").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("Machine")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End Sub
To combine with this
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
On Error Resume Next
If Intersect(Target, Range("P16:P17")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xPTable = Worksheets("Summary").PivotTables("PivotTable2")
Set xPFile = xPTable.PivotFields("Machine")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
End Sub
Appreciate any help, thank you!
Rather than just Exiting if there is no intersection, flip it around and proceed if there is an intersection.
Your code, refactored along with a few other improvements
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Application.ScreenUpdating = False
If Target.CountLarge > 1 Then
' User changed >1 cells. What now?
Exit Sub
End If
' On Error Resume Next <~~ don't do this globally!
If Not Intersect(Target, Me.Range("L3:L4")) Is Nothing Then
On Error Resume Next '<~~ Keep it tight around a potential error
' If the Change event is on Sheet Summary, use Me instead
Set xPTable = Me.PivotTables("PivotTable1")
' If the Change Event is NOT on Sheet Summary, be explicit on the workbook
'Set xPTable = Me.Parent.Worksheets("Summary").PivotTables("PivotTable1")
On Error GoTo 0
ElseIf Not Intersect(Target, Me.Range("P16:P17")) Is Nothing Then
On Error Resume Next
Set xPTable = Me.PivotTables("PivotTable2")
On Error GoTo 0
End If
If Not xPTable Is Nothing Then
On Error Resume Next '<~~ in case Machine doesn't exist
Set xPFile = xPTable.PivotFields("Machine")
On Error GoTo 0
If Not xPFile Is Nothing Then
xStr = Target.Value ' .Text is dangerous. Eg it can truncate if the column is too narrow
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
End If
End If
Application.ScreenUpdating = True
End Sub
I think there are more options for refactoring.
Put the basic routine into a seperate sub in a modul. This sub can then be called from the _change-events of both sheets. Advantage: if you want to change the logic of the sub - you do it in one place, not two. Or maybe there will be a third sheet that wants to use the same logic. (DRY-principle: don't repeat yourself)
I like to "externalize" on error resume next if necessary into tryGet-functions. Thereby minimizing the risk of its usage (which is in this case ok)
This is the generic sub - based on chris neilsens suggestion plus the comments from VBasic2008
Maybe you adjust the name of the sub to be more precise in what you want to achieve.
Public Sub handleMachineField(Target As Range, RangeToCheck As Range, PTName As String)
On Error GoTo err_handleMachineField
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Application.ScreenUpdating = False
If Target.CountLarge > 1 Then
' User changed >1 cells. What now?
Exit Sub
End If
If Not Intersect(Target, RangeToCheck) Is Nothing Then
Set xPTable = tryGetPivotTable(Target.Parent, PTName)
End If
If Not xPTable Is Nothing Then
Set xPFile = tryGetPivotField(xPTable, "Machine")
If Not xPFile Is Nothing Then
xStr = Target.Value ' .Text is dangerous. Eg it can truncate if the column is too narrow
Application.EnableEvents = False
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.EnableEvents = True
End If
End If
exit_handleMachineField:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
err_handleMachineField:
MsgBox Err.Description
Resume exit_handleMachineField
End Sub
Public Function tryGetPivotTable(ws As Worksheet, PTName As String) As PivotTable
'in case pivot table does not exist no error is thrown
'calling sub has to check for nothing instead
On Error Resume Next
Set tryGetPivotTable = ws.PivotTables(PTName)
On Error GoTo 0
End Function
Public Function tryGetPivotField(pt As PivotTable, FieldName As String) As PivotField
'in case field does not exist no error is thrown
'calling sub has to check for nothing instead
On Error Resume Next
Set tryGetPivotField = pt.PivotFields(FieldName)
On Error GoTo 0
End Function
And this is how you would call it form the worksheet events:
Private Sub Worksheet_Change(ByVal Target As Range)
handleMachineField Target, Me.Range("L3:L4"), "PivotTable1"
End Sub
By the way: this is another advantage of putting the check into a sub. When reading the code in the change-event you immediately know what will happen - you don't have to read through all the code lines to understand what is going on.
I have a code that builds up and selects the range to copy it over to another worksheet in another sub.
Sub SelectREZ()
'Disable screen update
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Declare variables
Dim c As Range, ws As Worksheet
Dim rngG As Range, lastJ, rngJ As Range
Set ws = ActiveSheet
For Each c In Intersect(ws.UsedRange, ws.Columns("C"))
Set rngJ = c.EntireRow.Columns("J")
If c = "REZ" Then
AddRange rngG, c.EntireRow
'Remember the "ITEM NO."
lastJ = rngJ.Value
Else
If Len(lastJ) > 0 Then
If rngJ.Value Like lastJ & "*" Then
AddRange rngG, c.EntireRow
Else
lastJ = ""
End If
End If
End If
Next c
rngG.Select
End Sub
'Utility sub for building up a range
Sub AddRange(rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
'Disable screen update
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
And I've ran into a situation when the range is empty and macro dies on the line
rngG.Select
How do I prevent such macro crash and quit the sub if range to select is empty?
I mean I could do:
On Error Resume Next
rngG.Select
But it seems like a sledgehammer way to approach it.
My code is as below:
Sub NewWorksheetTest()
Dim wsname As String
wsname = InputBox("Enter a name for the new worksheet")
On Error GoTo BadEntry
Sheets.Add
ActiveSheet.Name = wsname
Exit Sub
BadEntry:
MsgBox Err.Number & " :" & Err.Description, vbInformation, "There is an error...."
End Sub
My understanding is if I input a bad name (e.g. duplicate or containing ?/), there is a message explaining the reasons and at the same time the system stops a new sheet from being added.
An error msg is there but a new sheet is added.
As Tim Williams said, On Error GoTo BadEntry only works when the error appears, and sheets.add has no error so it will run normally.
This is another version you can use
vs1-no error checking
Option Compare Text
Sub NewWorksheetTest()
Dim wsname As String
wsname = InputBox("Enter a name for the new worksheet")
If Not (Checks_Sheetname (wsname)) Then Exit Sub 'check correct name
If Check_SheetExists(wsname) Then Exit Sub 'check dulicate
Sheets.Add
ActiveSheet.Name = wsname
End Sub
'https://learn.microsoft.com/en-us/office/vba/excel/concepts/workbooks-and-worksheets/name-a-worksheet-by-using-a-cell-value
Private Function Checks_Sheetname (wsname As String) As Boolean
If Len(wsname) > 31 Then Checks_Sheetname = False:exit function 'check sheetname length
Dim lst_str As Variant, item As Variant
lst_str = Array("/", "\", "[", "]", "*", "?", ":")
For Each item In lst_str
If InStr(wsname, item) > 0 Then
'...
Checks_Sheetname = False: Exit Function
End If
Next item
Checks_Sheetname = True
End Function
'https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
Private Function Check_SheetExists(wsname As String) As Boolean
For Each ws In Worksheets
If wsname = ws.Name Then
MsgBox ("exist")
Check_SheetExists = True
Exit Function
End If
Next ws
End Function
vs2: error checking
Sub NewWorksheetTest()
Dim wsname As String
wsname = InputBox("Enter a name for the new worksheet")
On Error GoTo BadEntry
Dim Act_wsname As String: Act_wsname = ActiveSheet.Name
ActiveSheet.Name = wsname: ActiveSheet.Name = Act_wsname 'checksyntax
Dim ws As Worksheet: Set ws = Sheets(wsname) 'check dulicate
If Not (ws Is Nothing) Then Exit Sub
Sheets.Add
ActiveSheet.Name = wsname
Exit Sub
BadEntry:
MsgBox Err.Number & " :" & Err.Description, vbInformation, "There is an error...."
End Sub
If the rename fails then you need to remove the added sheet
Sub NewWorksheetTest()
Dim wsname As String, ws As Worksheet
wsname = InputBox("Enter a name for the new worksheet")
On Error GoTo BadEntry
Set ws = Sheets.Add()
ws.Name = wsname
Exit Sub
BadEntry:
MsgBox Err.Number & " :" & Err.Description, vbInformation, "There is an error...."
If Not ws Is Nothing Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End Sub
I'm working with a sub which calls an input box to copy selected cells from a sheet and paste them into a multicolumn listbox. I've finally got everything working correctly, except the error 424 when the user cancels the inputbox. I've read through countless help threads regarding this error and have found nothing that seems to be able to handle the error for me. I'm hoping that someone out there can tell me if something is wrong with the code below (aside from 12 million exit sub attempts to stop the error), or possibly give me an idea of another area (Declarations, Initialization, Activate?) that I should be checking. Any ideas are appreciated, thanks.
Private Sub CopyItemsBtn_Click()
Dim x As Integer
Dim rSelected As Range, c As Range
Dim wb
Dim lrows As Long, lcols As Long
x = ProformaToolForm.ItemsLB.ListCount
'Prompt user to select cells for formula
On Error GoTo cleanup
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
If Err.Number = 424 Then
Debug.Print "Canceled"
Exit Sub
ElseIf Err.Number <> 0 Then
Debug.Print "unexpected error"
Exit Sub
End If
If rSelected.Rows.Count < 1 Or rSelected.Columns.Count < 1 Then
Exit Sub
End If
Err.Clear
On Error GoTo 0
'Only run if cells were selected and cancel button was not pressed
If Not rSelected Is Nothing Then
For Each c In rSelected
With ProformaToolForm.ItemsLB
.AddItem
.List = rSelected.Cells.Value
End With
Next
Else
Exit Sub
End If
cleanup: Exit Sub
End Sub
After some cleanup, here's my attempt with Tim's code:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range, c As Range
Dim wb
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
'Prompt user to select cells for formula
On Error Resume Next
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
On Error GoTo 0
If rSelected Is Nothing Then
MsgBox "no range selected", vbCritical
Exit Sub
End If
For Each c In rSelected
With ProformaToolForm.ItemsLB
.AddItem
.List = rSelected.Cells.Value
End With
Next
End Sub
Here's how I'd tend to do this:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range
On Error Resume Next
Set rSelected = Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
On Error GoTo 0
If rSelected Is Nothing Then
MsgBox "no range selected!", vbCritical
Exit Sub
End If
'continue with rSelected
End Sub
Found a solution, from Dirk's final post here. For anyone interested, here is the working code:
Private Sub CopyItemsBtn_Click()
Dim rSelected As Range
Dim wb
Dim MyCol As New Collection
wb = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*;*.xm*")
If wb <> False Then
Workbooks.Open wb
End If
MyCol.Add Application.InputBox(Prompt:= _
"Select cells to copy", _
Title:="Transfer Selection", Type:=8)
If TypeOf MyCol(1) Is Range Then Set MyRange = MyCol(1)
Set MyCol = New Collection
If rSelected Is Nothing Then
MsgBox "no range selected", vbCritical
Exit Sub
End If
ProformaToolForm.ItemsLB.List = rSelected.Value
End Sub
The problem is that when I change the value in I16 or I17 I get an error. How
can I prevent this error from happening?
I check in I16 and I17 for the sheetnames, because every week an updated sheet comes available.
Thank you
Sub Compare()
Call compareSheets(range("I16").Value, range("I17").Value)
End Sub
Sub compareSheets(Sofon As String, Sofon2 As String)
Dim mycell As range
Dim mydiffs As Integer
For Each mycell In ActiveWorkbook.Worksheets(Sofon2).range("M:M")
If Not mycell.Value = ActiveWorkbook.Worksheets(Sofon).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
MsgBox mydiffs & " differences found in Column M (Salesman)", vbInformation
ActiveWorkbook.Sheets(Sofon2).Select
End Sub
Just to show what I was thinking.
I agree with puzzlepiece87 that On Error is finicky, but with something this simple I would use it to avoid the excess loops.
Sub compareSheets(Sofon As String, Sofon2 As String)
Dim mycell As Range
Dim mydiffs As Integer
On Error GoTo nosheet
For Each mycell In ActiveWorkbook.Worksheets(Sofon2).Range("M:M")
If Not mycell.Value = ActiveWorkbook.Worksheets(Sofon).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
MsgBox mydiffs & " differences found in Column M (Salesman)", vbInformation
ActiveWorkbook.Sheets(Sofon2).Select
Exit Sub
nosheet:
If Err.Number = 9 Then
MsgBox "One or both sheets do not exist"
Else
MsgBox Err.Description
End If
End Sub
Since the OP wanted an ISERROR type of solution, I decided to post the code which incorporates a function to check if a sheet exists in a workbook. The concept is similar to answers already posted, but it keeps any On Error statements strictly inside the function and uses regular code blocks to evaluate errors.
Sub Compare()
Dim bGo As Boolean
Dim s1 As String, s2 As String
s1 = Range("I16").Value2
s2 = Range("I17").Value2
If Not WorksheetExist(s1) Then
bGo = False
MsgBox "The sheet " & s1 & " does not exist in this workbook."
End If
If Not WorksheetExist(s2) Then
bGo = False
MsgBox "The sheet " & s2 & " does not exist in this workbook."
End If
If bGo Then compareSheets s1, s2
End Sub
Function WorksheetExist(sName As String, Optional wb As Workbook) As Boolean
Dim wbCheck As Workbook, ws As Worksheet
If wb Is Nothing Then Set wbCheck = ThisWorkbook Else: Set wbCheck = wb
On Error Resume Next
Set ws = wbCheck.Sheets(sName)
On Error GoTo 0
If Not ws Is Nothing Then WorksheetExist = True Else: WorksheetExist = False
End Function
And, based on #puzzlepiece87 methodology, here is an improved WorksheetExist Function that eliminates of On Error statements altogether.
Function WorksheetExist(sName As String, Optional wb As Workbook) As Boolean
Dim wbCheck As Workbook, ws As Worksheet
If wb Is Nothing Then Set wbCheck = ThisWorkbook Else: Set wbCheck = wb
WorksheetExist = False
For Each ws In wbCheck.Worksheets
If ws.Name = sName Then
WorksheetExist = True
Exit For
End If
Next
End Function
You could use something similar to this to call compareSheets. It will warn you if either of the two ranges do not correspond to sheet names and won't call compareSheets if true.
Dim Sheet1 As Worksheet
Dim boolI16SheetCheck As Boolean
Dim boolI17SheetCheck As Boolean
boolI16SheetCheck = False
boolI17SheetCheck = False
For Each Sheet1 in ActiveWorkbook.Worksheets
If Sheet1.Name = Activesheet.Range("I16").Value Then boolI16SheetCheck = True
If Sheet1.Name = Activesheet.Range("I17").Value Then boolI17SheetCheck = True
If boolI16SheetCheck = True And boolI17SheetCheck = True Then
Call compareSheets(range("I16").Value, range("I17").Value)
Exit Sub
End If
Next Sheet1
If boolI16SheetCheck = False Then
If boolI17SheetCheck = False Then
Msgbox "Neither I16 nor I17 sheet found."
Else
Msgbox "I16 sheet not found."
End If
Else
Msgbox "I17 sheet not found."
End If
End Sub