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.

18445

[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