Help merging two pieces of VBA code

N

Nordicrx8

Board Regular
Joined
Dec 10, 2015
Messages
143
Office Version
  1. 365
Platform
  1. Windows
Hey All!

I'm stuck here. I have two VBA tasks I want to run. When I run them individually, they both work fine. When I try to combine them, the VBA runs in an infinite loop.

This code is looking for a change in a specific cell (which is a formula) and when it sees the change, it selects the cell, "presses" enter, and triggers a pivot table slicer update.

VBA Code: 
Private Sub Worksheet_Calculate()
    Dim Target As Range
    Set Target = Range("J2")

    If Not Intersect(Target, Range("J2")) Is Nothing Then
    
    Sheets("Helper_Bulk").Select
    Sheets("Helper_Bulk").Range("A1").Select
    ActiveCell.FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    Sheets("Helper_Bulk").Range("A2").Select
    If Sheets("Helper_Bulk").Range("D1") = "Yes" Then
        MsgBox "Note: There is no Bulk Data loaded for this zone. Please contact the MDM Team for assistance."
End If

    Sheets("Helper_Rate").Select
    Sheets("Helper_Rate").Range("A1").Select
    ActiveCell.FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    Sheets("Helper_Rate").Range("A2").Select
    If Sheets("Helper_Rate").Range("D1") = "Yes" Then
        MsgBox "Note: There is no Rate Data loaded for this zone. Please contact the MDM Team for assistance."
End If
    
    Sheets("Helper_MAT").Select
    Sheets("Helper_MAT").Range("A1").Select
    ActiveCell.FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    Sheets("Helper_MAT").Range("A2").Select
    If Sheets("Helper_MAT").Range("D1") = "Yes" Then
        MsgBox "Note: There is no Material Data loaded for this zone. Please contact the MDM Team for assistance."
End If
End If
    Sheets("Main").Select
    Range("A1").Select
 
End Sub


This code hides and blank rows or columns on the main tab of the workbook, where the data is displayed.

VBA Code: 
Sub Hide()
    
StartRow = 12
EndRow = 200
ColNum = 12
For i = StartRow To EndRow
If Cells(i, ColNum).Value <> “TRUE” Then
Cells(i, ColNum).EntireRow.Hidden = True
Else
Cells(i, ColNum).EntireRow.Hidden = False
End If
Next i

Dim c As Range
    For Each c In Range("M9:AG9").Cells
        If c.Value = "True" Then
            c.EntireColumn.Hidden = True
        End If
    Next c

End Sub

When I try to add the VBA code that hides the blank rows/columns to the code that performs the refresh, it ends up trying to refresh indefinitely. I'm assuming it has to something to do with the refresh being worksheet_calculate, but I don't know how to solve for it and google hasn't helped. (Perhaps I'm using the wrong search terms)

Any help would be greatly appreciated! Thank you!
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
I think you want to use the Worksheet_Change event instead. Setting the TARGET to J2 and then using the INTERSECT operation is redundant. It will always run. If you use the Worksheet_Change event, and change the value in J2, then and only then will the following code run.

I also cleaned it up a bit. You want to avoid using .Select unless it's really necessary.

This should work.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("J2")) Is Nothing Then

    Dim BULK As Worksheet:  Set BULK = Sheets("Helper_Bulk")
    Dim RATE As Worksheet:  Set RATE = Sheets("Helper_Rate")
    Dim MAT As Worksheet:   Set MAT = Sheets("Helper_MAT")
    
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    BULK.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    RATE.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    MAT.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    
    If BULK.Range("D1") = "Yes" Then
        MsgBox "Note: There is no Bulk Data loaded for this zone. Please contact the MDM Team for assistance."
    End If

    If RATE.Range("D1") = "Yes" Then
        MsgBox "Note: There is no Rate Data loaded for this zone. Please contact the MDM Team for assistance."
    End If
    
    If MAT.Range("D1") = "Yes" Then
        MsgBox "Note: There is no Material Data loaded for this zone. Please contact the MDM Team for assistance."
    End If
    
    Sheets("Main").Select
    Range("A1").Select

    Call Hide

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End If

End Sub

You should make a copy of your workbook and test the code on the copy.
 
Upvote 0
I see why you were selecting those sheets now. So they would know what sheet the messagebox pertained to.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("J2")) Is Nothing Then

    Dim BULK As Worksheet:  Set BULK = Sheets("Helper_Bulk")
    Dim RATE As Worksheet:  Set RATE = Sheets("Helper_Rate")
    Dim MAT As Worksheet:   Set MAT = Sheets("Helper_MAT")
    
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    BULK.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    RATE.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    MAT.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    
    If BULK.Range("D1") = "Yes" Then
        BULK.Select
        MsgBox "Note: There is no Bulk Data loaded for this zone. Please contact the MDM Team for assistance."
    End If

    If RATE.Range("D1") = "Yes" Then
        RATE.Select
        MsgBox "Note: There is no Rate Data loaded for this zone. Please contact the MDM Team for assistance."
    End If
    
    If MAT.Range("D1") = "Yes" Then
        MAT.Select
        MsgBox "Note: There is no Material Data loaded for this zone. Please contact the MDM Team for assistance."
    End If
    
    MAIN.Select
    Call Hide

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End If

End Sub
 
Upvote 0
Hey there! thanks so much for the quick response and for the re-write! I don't use VBA often, so generally its a messy blob of code I slap together after google searching and recording macros. lol

I tried it out, and I think this will do it, but I'm running into one issue.

This code is basically "double clicking" on a cell and "pressing enter" on it...

VBA Code: 
    BULK.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    RATE.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    MAT.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"

Which then forces this block of code to run on each worksheet:

VBA Code: 
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("A1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Helper_Rate").PivotTables("PivotTable7")
    Set xPFile = xPTable.PivotFields("Zone")
    xStr = Target.Text
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True
  
End Sub


Helper_Mat WS:

VBA Code: 
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("A1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Helper_Mat").PivotTables("PivotTable8")
    Set xPFile = xPTable.PivotFields("Zone")
    xStr = Target.Text
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True
End Sub


Helper_Bulk WS:

VBA Code: 
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("A1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Helper_Bulk").PivotTables("PivotTable4")
    Set xPFile = xPTable.PivotFields("Zone")
    xStr = Target.Text
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True
End Sub

For some reason, the updated code isn't forcing the change event for the 3 sheets to take place - any thoughts?

thanks again so much!
 
Last edited:
Upvote 0
I think I can get around this. Quick question though. Do you only want this to run when J2 changes? If so, is it only on the 'Main' sheet?
 
Upvote 0
lrobbo314 said:
I think I can get around this. Quick question though. Do you only want this to run when J2 changes? If so, is it only on the 'Main' sheet?
Click to expand...
Yes - well sort of. I really just need them to trigger any time a selection is made on the slicer, which then forces the three pivot tables to update. this was the only way I could figure out how to do it!
 
Upvote 0
If so, you may be able to use this event instead.

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

End Sub

Either way, this should work.

Main:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("J2")) Is Nothing Then

    Dim BULK As Worksheet:  Set BULK = Sheets("Helper_Bulk")
    Dim RATE As Worksheet:  Set RATE = Sheets("Helper_Rate")
    Dim MAT As Worksheet:   Set MAT = Sheets("Helper_MAT")
    Dim MAIN As Worksheet:  Set MAIN = Sheets("Main")

    BULK.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    RATE.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    MAT.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
   
    If BULK.Range("D1") = "Yes" Then
        BULK.Select
        MsgBox "Note: There is no Bulk Data loaded for this zone. Please contact the MDM Team for assistance."
    End If

    If RATE.Range("D1") = "Yes" Then
        RATE.Select
        MsgBox "Note: There is no Rate Data loaded for this zone. Please contact the MDM Team for assistance."
    End If
   
    If MAT.Range("D1") = "Yes" Then
        MAT.Select
        MsgBox "Note: There is no Material Data loaded for this zone. Please contact the MDM Team for assistance."
    End If
   
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
   
    MAIN.Select
    Call Hide

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End If

End Sub

Then for each of your Pivot Table events add a
Application.EnableEvents = False
Application.EnableEvents = True
at the top and bottom of the subroutine like this

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xStr As String
    On Error Resume Next
    If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Helper_Bulk").PivotTables("PivotTable4")
    Set xPFile = xPTable.PivotFields("Zone")
    xStr = Target.Text
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
 
Upvote 0
I think we are really close, but something is still preventing the auto-refresh when a new item is selected in the slicer.

This code is when I recorded a macro of double clicking into the cell and pressing enter. These ranges are basically just pointing to the slicer selection - when a slicer selection is made, the range updates to the selected item. (so it changes with every slicer selection)

If I manually double click and press enter, it updates all the pivot tables and code works perfectly. But if i just make a new selection in the slicer, nothing happens. I have to manually double click the cell/enter for it to work, or assign the code to a button to have the user "refresh" after every new slicer selection. (Which I may just have to settle for, if we can't solve for it)

VBA Code: 
    BULK.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    RATE.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"
    MAT.Range("A1").FormulaR1C1 = "=Zone_MDM!R[3]C[8]"

I've been trying to get it to work for a few hours now with no luck. Did some googling, and tried this code too, but still nothing.

VBA Code: 
BULK.Range("A1").Application.DoubleClick
BULK.Range("A1").Application.SendKeys "{ENTER}"
RATE.Range("A1").Application.DoubleClick
RATE.Range("A1").Application.SendKeys "{ENTER}"
MAT.Range("A1").Application.DoubleClick
MAT.Range("A1").Application.SendKeys "{ENTER}"

Any ideas on how to force the double click/enter after every slicer change?

Thanks again for all your help - really appreciate it, and you!
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Speeding up a VBA Macro & Code Cleanup
Replies
3
Views
339
Nordicrx8
N
P
  • Question
Help with Vba Code
Replies
3
Views
167
Coyotex3
C
Ottsel
  • Solved
Select Multiple Cells Depending on Value
Replies
2
Views
428
Ottsel
Ottsel
L
  • Solved
VBA remove leading zeros
2
Replies
14
Views
988
Joe4
Joe4
I
  • Question
How to make VBA loop check excel sheet continuously
Replies
3
Views
480
aaewalsh
aaewalsh

Forum statistics

Threads
1,215,110
Messages
6,123,147
Members
449,098
Latest member
Doanvanhieu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top