• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA code to pair cells' formatting

carics

Member
Hello,


In the same spreadsheet I have two twin data tables. One is for manually entering data, the other one shows the result of the calculation of the manual entry and some other figures.

Now I would like to mark some cell somehow (patterns, font color, bold, etc.) in the first table in a way that the "twin" cell in the second table would change formatting to pair that one - and the other way around would be nice as well.


Table 1-> D5:R23

Table 2-> D28:R46


So for example, D5 and D28 cells should be "twins" in terms of formatting.


Is this easy to do with VBA code?


Thanks!
 
Carics

Is the pairing based on any Criteria like cell value or purely the position in the 2 tables? ie: The 2, 5th Cells will have the same format
 
Hi Hui,


Man, you're fast! It is just about position:


D5 = D28

E5 = E28

F5 = F28

D6 = D29

...and so on
 
Sorry to insist, maybe it is too much to ask (I have no clue in VBA...), but any idea?


thanks in advance
 
Carics

I had started work on this and got side tracked so my apologies


The following VBA code will do sort of what you want

Copy and paste it into a Code page for the Worksheet you are working on


To simplify the code a little bit you will need to setup 2 named ranges

Table1: D5:R23

Table2: D28:R46


Problem is that this code only runs when a value changes, not a format

So you could set a format and then put a value in a cell

Or set a format and then simply press F2 Enter

[pre]
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iRange As Range
Dim xOff As Long, yOff As Long

Application.EnableEvents = False
xOff = 0 'Horizntal Offset
yOff = 23 'Vertical Offset

Set iRange = Application.Intersect(Target, Range("Table1"))

If iRange Is Nothing Then GoTo 10
Target.Copy
Target.Offset(yOff, xOff).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

GoTo Last

10:
Set iRange = Application.Intersect(Target, Range("Table2"))
If iRange Is Nothing Then GoTo Last
Target.Copy
Target.Offset(-yOff, xOff).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Last:
Application.EnableEvents = True
Target.Select

End Sub
[/pre]
 
Hello Hui,


No, please don't apologise, you are helping me! Do it on your time, I will just thank you :)


I will try it and get back to you!


Thanks again
 
Back
Top