VBA Worksheet change: nested If to run sub if transposed ranges don't match.

F

figment222

New Member
Joined
Mar 6, 2015
Messages
48
I have a range of column headers that is transposed from a list in column B. When a value from column B changes, I have a macro that will copy those values and transpose them into row 8, starting with R8. I want to prevent the user from changing the column headers.

I want the column and the headers to always match. I can't run the TransposeNames macro when the column headers change because it will trigger a cascade. BUT, if I could run the TransposeNames macro when the headers change IF the changes don't match, then I can avoid the cascade.

If they change the value in the header, it will trigger the macro to make the names match again. Changing that value will trigger the macro again, but because I have it nested in an IF statement that first compares the ranges, it won't trigger the cascade because the change resulted in a match. Does that make sense?

My question is how to write the If statement to run a macro only when column B and row 8 do not match.

In case it helps, here's the script for the TransposeNames Sub:
Code: 
Sub TransposeNames()
    Dim SourceRange As Range
    Dim TargetRange As Range
    
    Dim Start As Long, Final As Long
    
    Start = Range("B:B").Find("Feature Type", Range("B1")).Row
    Final = Range("B:B").Find("End", Range("B" & Start)).Row
    Set SourceRange = Range("B" & Start + 1 & ":B" & Final)
    Set TargetRange = Range("R8")
    SourceRange.Copy
    TargetRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
    TargetRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, Transpose:=True
    TargetRange.FormatConditions.Delete
    SourceRange.ClearOutline
    Range("A7").Select
End Sub
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
Maybe:
Code: 
Sub TransposeNames()
    Application.ScreenUpdating = False
    Dim SourceRange As Range
    Dim TargetRange As Range
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary")
    Dim Start As Long, Final As Long
    
    Start = Range("B:B").Find("Feature Type", Range("B1")).Row
    Final = Range("B:B").Find("End", Range("B" & Start)).Row - 1
    Set SourceRange = Range("B" & Start + 1 & ":B" & Final)
    Set TargetRange = Range("R8")
    
    For Each Rng In SourceRange
      If Not RngList.Exists(Rng.Value) Then
        RngList.Add Rng.Value, Nothing
      End If
    Next Rng
    For Each Rng In Range(Cells(8, "R"), Cells(8, Cells(8, Columns.Count).End(xlToLeft).Column))
      If Not RngList.Exists(Rng.Value) Then
        SourceRange.Copy
        TargetRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
        TargetRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, Transpose:=True
        TargetRange.FormatConditions.Delete
        SourceRange.ClearOutline
        Range("A7").Select
      End If
    Next Rng
    Set List = Nothing
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Awesome! This works great on it's own. How can I apply this to the worksheet change event only when Row 8 from R8 to the last column is changed?

I'm getting errors when I use this syntax to trigger your macro.

Code: 
Dim LastCol As Integer
With ActiveSheet
    LastCol = .Cells(8, .Columns.Count).End(xlToLeft).Column
End With


    If Target.Row = Range("R8", Range("R8").Offset(0, LastCol)).Row Then
        TransposeNames
        FillDownFormats
        MatchCompGrid
        MsgBox "Name Changes happen from Column B"
    End If

I don't necessarily want the macro to run when A8:Q8 are changed. Only when columns R and beyond are changed.
 
Upvote 0
Try:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range(Cells(8, "R"), Cells(8, Cells(8, Columns.Count).End(xlToLeft).Column))) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim SourceRange As Range
    Dim TargetRange As Range
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary")
    Dim Start As Long, Final As Long
    
    Start = Range("B:B").Find("Feature Type", Range("B1")).Row
    Final = Range("B:B").Find("End", Range("B" & Start)).Row - 1
    Set SourceRange = Range("B" & Start + 1 & ":B" & Final)
    Set TargetRange = Range("R8")
    
    For Each Rng In SourceRange
      If Not RngList.Exists(Rng.Value) Then
        RngList.Add Rng.Value, Nothing
      End If
    Next Rng
    For Each Rng In Range(Cells(8, "R"), Cells(8, Cells(8, Columns.Count).End(xlToLeft).Column))
      If Not RngList.Exists(Rng.Value) Then
        SourceRange.Copy
        TargetRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
        TargetRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, Transpose:=True
        TargetRange.FormatConditions.Delete
        SourceRange.ClearOutline
        Range("A7").Select
      End If
    Next Rng
    Set List = Nothing
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
It's giving me an error and highlighting the following line:

Code: 
Start = Range("B:B").Find("Feature Type", Range("B1")).Row

The error says: Run-time erro '-2147417848 (80010108)':
Method 'Find' of object 'Range' failed

I find this happens a lot when i'm fumbling around trying to get macros to run from the worksheet change event. Whether I click on "End" or "Debug", the sheet becomes unusable and I wind up having to quit without saving.

(I've learned to "save" before triggering any experimental code...
 
Upvote 0
Try replacing the old lines of code with these:
Code: 
Start = Range("B:B").Find("Feature Type", LookIn:=xlValues, lookat:=xlWhole).Row
Final = Range("B:B").Find("End", LookIn:=xlValues, lookat:=xlWhole).Row - 1
 
Upvote 0
Hi and thank you for your continued effort. I wound up getting it to work before I saw your suggestion, although I will bear that in mind if I run into trouble with it again. I kept the code as a separate sub and call it with the worksheet change event when the target is in the specified range.

Here's the code for the sub and then the code for the worksheet change event that calls it:
Code: 
Sub TransposeNames2()
    Application.ScreenUpdating = False
    Dim SourceRange As Range
    Dim TargetRange As Range
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary")
    Dim Start As Long, Final As Long
    
    Start = Range("B:B").Find("Feature Type", Range("B1")).Row
    Final = Range("B:B").Find("End", Range("B" & Start)).Row
    Set SourceRange = Range("B" & Start + 1 & ":B" & Final)
    Set TargetRange = Range("R8")
    
    For Each Rng In SourceRange
      If Not RngList.Exists(Rng.Value) Then
        RngList.Add Rng.Value, Nothing
      End If
    Next Rng
    For Each Rng In Range(Cells(8, "R"), Cells(8, Cells(8, Columns.Count).End(xlToLeft).Column))
      If Not RngList.Exists(Rng.Value) Then
        SourceRange.Copy
        TargetRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
        TargetRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, Transpose:=True
        TargetRange.FormatConditions.Delete
        SourceRange.ClearOutline
        FillDownFormats
        MatchCompGrid
        Range("A7").Select
      End If
    Next Rng
    Set List = Nothing
    Application.ScreenUpdating = True
End Sub

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
   
    If Intersect(Target, Range(Cells(8, "R"), Cells(8, Cells(8, Columns.Count).End(xlToLeft).Column))) Is Nothing Then Exit Sub
    TransposeNames2


End Sub

I have a few other macros being triggered by the worksheet change event for certain ranges, so that if any of the names change in column B, then it will transpose the names to the column headers and change any of the names in those columns, so they match the headers. Should someone change the headers, it will automatically copy the names again from column B, and transpose them, so they match again. If any values change in the columns, it will automatically change that value to match the column header. BEAUTIFUL! Thanks for your help on this!

For anyone else interested in this, here's the final code for the macros described in this thread:
Code: 
Sub TransposeNames2()
    Application.ScreenUpdating = False
    Dim SourceRange As Range
    Dim TargetRange As Range
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary")
    Dim Start As Long, Final As Long
    
    Start = Range("B:B").Find("Feature Type", Range("B1")).Row
    Final = Range("B:B").Find("End", Range("B" & Start)).Row
    Set SourceRange = Range("B" & Start + 1 & ":B" & Final)
    Set TargetRange = Range("R8")
    
    For Each Rng In SourceRange
      If Not RngList.Exists(Rng.Value) Then
        RngList.Add Rng.Value, Nothing
      End If
    Next Rng
    For Each Rng In Range(Cells(8, "R"), Cells(8, Cells(8, Columns.Count).End(xlToLeft).Column))
      If Not RngList.Exists(Rng.Value) Then
        SourceRange.Copy
        TargetRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
        TargetRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, Transpose:=True
        TargetRange.FormatConditions.Delete
        SourceRange.ClearOutline
        FillDownFormats
        MatchCompGrid
        Range("A7").Select
      End If
    Next Rng
    Set List = Nothing
    Application.ScreenUpdating = True
End Sub




Sub TransposeNames()
    Dim SourceRange As Range
    Dim TargetRange As Range
    
    Dim Start As Long, Final As Long
    
    Start = Range("B:B").Find("Feature Type", Range("B1")).Row
    Final = Range("B:B").Find("End", Range("B" & Start)).Row
    Set SourceRange = Range("B" & Start + 1 & ":B" & Final)
    Set TargetRange = Range("R8")
    SourceRange.Copy
    TargetRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
    TargetRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, Transpose:=True
    TargetRange.FormatConditions.Delete
    SourceRange.ClearOutline
    Range("A7").Select
End Sub

Code: 
Sub FillDownFormats()    Dim SourceRange As Range, TargetRange As Range, TotalRange As Range, FirstRow As Long, LastRow As Long, i As Long
    
    FirstRow = Range("B:B").Find("ID", Range("B1")).Row
    LastRow = Range("B:B").Find("End", Range("B8")).Row
    i = Range("B" & FirstRow & ":B" & LastRow).Count
    
    Set SourceRange = Range("R8", Range("R8").Offset(0, i - 1))
    Set TargetRange = Range("R9", SourceRange.Offset(i, 0))
    Set TotalRange = Range("R8", SourceRange.Offset(i, 0))
    
    SourceRange.FormatConditions.Delete
    SourceRange.Copy
    TargetRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
    SourceRange.ClearOutline
    SourceRange.Style = "Check Cell"
    TotalRange.HorizontalAlignment = xlCenter
    TotalRange.Columns.AutoFit
    Range("A7").Select
End Sub

Code: 
Sub MatchCompGrid()    Dim FirstRow As Long, LastRow As Long, i As Long, x As Long, c As Range, Header As String
    
    FirstRow = Range("B:B").Find("ID", Range("B1")).Row
    LastRow = Range("B:B").Find("End", Range("B8")).Row
    i = Range("B" & FirstRow & ":B" & LastRow).Count
    Header = Range("R8").Value
    
    For Each c In Range("R9", Range("R9").Offset(i - 1, i))
        If c.Value <> "" Then
            Cells(c.Row, c.Column).Value = Cells(8, c.Column).Value
        Else 'Do Nothing
        End If
    Next c
    
    
End Sub

Code: 
Sub MatchCompGrid2()    Dim FirstRow As Long, LastRow As Long, i As Long, x As Long, c As Range, Header As String
    
    FirstRow = Range("B:B").Find("ID", Range("B1")).Row
    LastRow = Range("B:B").Find("End", Range("B8")).Row
    i = Range("B" & FirstRow & ":B" & LastRow).Count
    Header = Range("R8").Value
    
    For Each c In Range("R9", Range("R9").Offset(i - 1, i))
        If c.Value = Cells(8, c.Column).Value Then
        ElseIf c.Value <> "" Then
            Cells(c.Row, c.Column).Value = Cells(8, c.Column).Value
        Else 'Do Nothing
        End If
    Next c
    
    
End Sub

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Column = Range("B:B").Column Then
        TransposeNames
        FillDownFormats
        MatchCompGrid
        MsgBox "All Options Match Column Headers for Compatibility Grid"
    End If
    
    Dim SourceRange As Range, TargetRange As Range, TotalRange As Range, FirstRow As Long, LastRow As Long, i As Long
    
    FirstRow = Range("B:B").Find("ID", Range("B1")).Row
    LastRow = Range("B:B").Find("End", Range("B8")).Row
    i = Range("B" & FirstRow & ":B" & LastRow).Count
    
    Set SourceRange = Range("R8", Range("R8").Offset(0, i - 1))
    Set TargetRange = Range("R9", SourceRange.Offset(i, 0))




    If Intersect(Target, TargetRange) Is Nothing Then
        If Intersect(Target, Range(Cells(8, "R"), Cells(8, Cells(8, Columns.Count).End(xlToLeft).Column))) Is Nothing Then Exit Sub
            TransposeNames2
        Else: MatchCompGrid2
    End If
End Sub

Thanks again!
 
Upvote 0
Regarding the code you helped me with for Transposing the names from column B to the column headers in Row 8, I'm trying to add another sub that will look at the values in column O and highlight any matching values in Range(Cells(9, "R"), Cells(9, Cells(9, Columns.Count).End(xlToLeft).Column)). I also want to avoid it considering blank values a "match".

I thought I could copy your code and then modify it a bit, because I felt it was a similar method (comparing two ranges), but I'm struggling with it. When I manually run it with F5, It only highlights R9:T9 and V9:X9. Any ideas? Here's the code:

Code: 
Sub HighlightCompGrid2()    
    Application.ScreenUpdating = False
    Dim Selected As Range
    Dim Grid As Range
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary")
    Dim Start As Long, Final As Long
    
    Start = Range("B:B").Find("Feature Type", Range("B1")).Row
    Final = Range("B:B").Find("End", Range("B" & Start)).Row
    Set Selected = Range("O" & Start + 1 & ":O" & Final)
    Set Grid = Range("R9")
    
    For Each Rng In Selected
      If Not RngList.Exists(Rng.Value) Then
        RngList.Add Rng.Value, Nothing
      End If
    Next Rng
    
    For Each Rng In Range(Cells(9, "R"), Cells(9, Cells(9, Columns.Count).End(xlToLeft).Column))
      If RngList.Exists(Rng.Value) Then
      Rng.Style = "Neutral"
      End If
    Next Rng
    Set List = Nothing
    Application.ScreenUpdating = True
End Sub

I had another idea I was piecing together for that same purpose, but I'm getting a "type mismatch" error.

Code: 
Sub HighlightCompGrid()
    Dim FirstRow As Long, LastRow As Long, i As Long, x As Long, c As Range
    Dim Selected As Range
    Dim Grid As Range
    
    FirstRow = Range("B:B").Find("ID", Range("B1")).Row
    LastRow = Range("B:B").Find("End", Range("B8")).Row
    i = Range("B" & FirstRow & ":B" & LastRow).Count
    
    Set Grid = Range("R9", Range("R9").Offset(i - 1, i - 1))
    Set Selected = Range("O9", Range("O9").Offset(i - 1, 0))
    
    Selected.Select
    
    For Each c In Grid
        If c.Value = Selected.Value Then
            Cells(c.Row, c.Column).Style = "Neutral"
        Else 'Do Nothing
        End If
    Next c
End Sub

Maybe neither of these are the right approach...
 
Last edited:
Upvote 0
Try:
Code: 
 Set Selected = Range("O" & Start + 1 & ":O" & Final - 1)
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA - Select a range of cells with keystrokes but don't want to see the cells
Replies
6
Views
288
Dan2k
D
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
258
tixarah
T
duteberta
  • Question Question
VBA code to auto sort table based on any change within a specific column
2
Replies
17
Views
1K
Peter_SSs
Peter_SSs
D
  • Locked
  • Question Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
315
RoryA
RoryA
B
  • Solved
Run macro when drop-down value changes
Replies
3
Views
2K
Joe4
Joe4

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

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