Looping Mirrored Cells between Worksheets

[shp025]

Hello. I'm new to VBA and I am currently working on a spreadsheet in which cells are mirrored between different worksheets. So when someone inputs something into cell "B6" in one worksheet the change will reflect into cell "C1" in another worksheet and vice versa. I was able to write the mirrored code for individual pairs of cells. However, I have to do this to the entire workbook in multiple worksheets for thousands of paired cells - which makes the file size way too large. The way the sheet is formatted, every worksheet has information that is mirrored in a "database" spreadsheet. One column in the database represents one worksheet. So I want to create a loop that allows me to repeat the mirrored code of one worksheet, but offset each loop by one column.

Below is the code that I have so far (simplified to include only two pairs of mirrored cells). Because the first two sheets are the Table of Contents and Database respectively, I started the worksheet count at i = 3. Right now the sheet doesn't respond to any changes that I make and I'm wondering what I did wrong.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)


Dim wscount As Integer
Dim i As Integer


wscount = ActiveWorkbook.Worksheets.Count


If Target.Count > 1 Then Exit Sub


For i = 3 To wscount


Set wksData = Worksheets("Database")
Set wksC = ActiveWorkbook.Worksheets(i).Name


If wksC.Name = "Sheet" & i Then


'CPT Code
If Target = wksData.Range(Cells(1, i)) Then
Application.EnableEvents = False
wksC.Range("B6").Value = wksData.Range(Cells(1, i)).Value
Application.EnableEvents = True
ElseIf Target = wksC.Range("B6") Then
Application.EnableEvents = False
wksData.Range(Cells(1, i)).Value = wksC.Range("B6").Value
Application.EnableEvents = True
End If


'Anatomic Region
If Target = wksData.Range(Cells(2, i)) Then
Application.EnableEvents = False
wksC.Range("B6").Value = wksData.Range(Cells(2, i))
Application.EnableEvents = True
ElseIf Target = wksC.Range("B6") Then
Application.EnableEvents = False
wksData.Range(Cells(2, i)).Value = wksC.Range("B6").Value
Application.EnableEvents = True
End If


End If
Next i

Any help would be greatly appreciated!

[Paul_Hossler]

. So when someone inputs something into cell "B6" in one worksheet the change will reflect into cell "C1" in another worksheet and vice versa. I was able to write the mirrored code for individual pairs of cells

1. Where do these mirroring rules reside?

Because the first two sheets are the Table of Contents and Database respectively, I started the worksheet count at i = 3.

2. That's probably not a reliable way to exclude the DB and TOC sheets

3. Do you have your code in the ThisWorkbook module?

[shp025]

1. Where do these mirroring rules reside?

So originally, I had used this code to mirror Cell C1 to Cell B8.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)


If Target.Count > 1 Then Exit Sub
Dim wksData As Worksheet, wksC As Worksheet
Set wksData = Worksheets("Database")
Set wksC = Worksheets("Routine Chest Contrast - GE")


If Target = wksData.Range("C1") ThenApplication.EnableEvents = False
wksC.Range("B8").Value = wksData.Range("C1")
Application.EnableEvents = True
ElseIf Target = wksC.Range("B8") Then
Application.EnableEvents = False
wksData.Range("C1").Value = wksC.Range("B8").Value
Application.EnableEvents = True
End If

You can see under 'CPT Code where a similar code is, but relative to sheet number to designate a new column.

2. That's probably not a reliable way to exclude the DB and TOC sheets

Could you explain why? I'd love any insight to understanding the problems with this VBA. And are there any alternatives to looping but keeping the i integer to use as a relative reference? I can't figure out an easier way to make every cell in one worksheet reference a column in the database worksheet without it.

3. Do you have your code in the ThisWorkbook module?

Yes. I have all of the VBA under ThisWorkbook

[Paul_Hossler]

Can you post a small sample workbook?

I'm confused by how you want the columns to be filled

[shp025]

Can you post a small sample workbook?

I'm confused by how you want the columns to be filled

Sure! I got rid of a lot of rows on the database and there are more columns in each individual sheet, but otherwise the sheets are similar. I only wrote out the code for Sheet 3 and I would like to apply a loop so that Sheets 4, 5, and so on will all mirror in their designated column. I hope this clarifies the problem.

Forum_Example.xlsm

[Paul_Hossler]

I think I got most of what you wanted to do

See if this moves you farther along

I set it up so that if your change Database, the row header in col B and the sheet name in row 1 are used to determine the sheet and cell

If you change a sheet x, the row name in col A and the sheet name are used to index into database

Option Explicit
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wsCount As Integer
    Dim i As Integer
    Dim wksData As Worksheet
    Dim iRow As Long, iCol As Long
    Dim sRow As String, sCol As String
    Dim r As Range
    
    Set wksData = Worksheets("Database")
     
    'exit is more than one cell is changed
    If Target.Count > 1 Then Exit Sub
    
    Set r = wksData.Range("B1").CurrentRegion
    
    If Sh Is wksData Then
                
        'if not in block of headers and row name then get out
        If Intersect(r, Target) Is Nothing Then Exit Sub
        
        sRow = Intersect(Target.EntireRow, r.Columns(1)).Value
        sCol = Intersect(Target.EntireColumn, r.Rows(1)).Value
        
        iRow = 0
        On Error Resume Next
        iRow = Application.WorksheetFunction.Match(sRow, Worksheets(sCol).Columns(1), 0)
        On Error GoTo 0
        
        On Error GoTo NiceExit
        If iRow = 0 Then
            MsgBox sRow & " not found on sheet " & sCol
            Err.Raise 10000, sRow & " not found on sheet " & sCol
        Else
            Application.EnableEvents = False
            Worksheets(sCol).Cells(iRow, 2).Value = Target.Value
            Application.EnableEvents = True
        End If
        On Error GoTo 0
    
    Else
        If Intersect(Sh.Columns(2), Target) Is Nothing Then Exit Sub
    
        sRow = Target.Offset(0, -1).Value
        
        iRow = 0
        iCol = 0
        On Error Resume Next
        iRow = Application.WorksheetFunction.Match(sRow, r.Columns(1), 0)
        iCol = Application.WorksheetFunction.Match(Sh.Name, r.Rows(1), 0)
        On Error GoTo 0
        
        On Error GoTo NiceExit
        If iRow = 0 Then
            MsgBox sRow & " not found on sheet " & wksData.Name
            Err.Raise 10000, sRow & " not found on sheet " & wksData.Name
        ElseIf iCol = 0 Then
            MsgBox sCol & " not found on sheet " & wksData.Name
            Err.Raise 10000, sCol & " not found on sheet " & wksData.Name
        Else
            Application.EnableEvents = False
            r.Cells(iRow, iCol).Value = Target.Value
            Application.EnableEvents = True
        End If
        On Error GoTo 0
    End If
    
    
NiceExit:
    Err.Clear
    Application.EnableEvents = True
End Sub

[shp025]

This is amazing! I didn't realize that there was an index/match function within VBA as well. However, I realized that you had to reformat the input sheets from two sets of columns to one column for the VBA to work. I am told I need to have the cells on the input worksheets in a particular format (for printability and readability). I've been trying to use VBA to rearrange cells before your VBA starts into a single column and rearrange the cells back after your VBA finishes, but it doesn't seem to work. When editing cells in the second pair of columns, it doesn't update the database. Do you have any advice my particular problem? Maybe I just fundamentally don't understand something about the VBA.

So when someone inputs something into cell "B6" in one worksheet the change will reflect into cell "C1" in
'another worksheet and vice versa
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wsCount As Integer
    Dim i As Integer
    Dim wksData As Worksheet
    Dim iRow As Long, iCol As Long
    Dim sRow As String, sCol As String
    Dim r As Range
    
    'exit is more than one cell is changed
    If Target.Count > 1 Then Exit Sub
    
    Set wksData = Worksheets("Database")
    
'This is my attempt at trying to move cells over into one column 
    If Not Intersect(Target, Range("G6:H13")) Is Nothing Then
        For i = 1 To 8
            Application.EnableEvents = False
            Cells((15 + i), 1).Value = Cells((5 + i), 7).Value
            Cells((15 + i), 2).Value = Cells((5 + i), 8).Value
            Application.EnableEvents = True
    Next i
    End If
     
    
    Set r = wksData.Range("B1").CurrentRegion
    
    If Sh Is wksData Then
                
        'if not in block of headers and row name then get out
        If Intersect(r, Target) Is Nothing Then Exit Sub
        
        sRow = Intersect(Target.EntireRow, r.Columns(1)).Value
        sCol = Intersect(Target.EntireColumn, r.Rows(1)).Value
        
        iRow = 0
        On Error Resume Next
        iRow = Application.WorksheetFunction.Match(sRow, Worksheets(sCol).Columns(1), 0)
        On Error GoTo 0
        
        On Error GoTo NiceExit
        If iRow = 0 Then
            MsgBox sRow & " not found on sheet " & sCol
            Err.Raise 10000, sRow & " not found on sheet " & sCol
        Else
            Application.EnableEvents = False
            Worksheets(sCol).Cells(iRow, 2).Value = Target.Value
            Application.EnableEvents = True
        End If
        On Error GoTo 0
    
    Else
        If Intersect(Sh.Columns(2), Target) Is Nothing Then Exit Sub
    
        sRow = Target.Offset(0, -1).Value
        
        iRow = 0
        iCol = 0
        On Error Resume Next
        iRow = Application.WorksheetFunction.Match(sRow, r.Columns(1), 0)
        iCol = Application.WorksheetFunction.Match(Sh.Name, r.Rows(1), 0)
        On Error GoTo 0
        
        On Error GoTo NiceExit
        If iRow = 0 Then
            MsgBox sRow & " not found on sheet " & wksData.Name
            Err.Raise 10000, sRow & " not found on sheet " & wksData.Name
        ElseIf iCol = 0 Then
            MsgBox sCol & " not found on sheet " & wksData.Name
            Err.Raise 10000, sCol & " not found on sheet " & wksData.Name
        Else
            Application.EnableEvents = False
            r.Cells(iRow, iCol).Value = Target.Value
            Application.EnableEvents = True
        End If
        On Error GoTo 0
    End If
    
    
NiceExit:
    Err.Clear
    Application.EnableEvents = True
End Sub