VBA for matching Sheet 1 columns to Sheet 2 columns - vba

Question

Sheet 1 has columns A-T. Some columns of Sheet 1 have formulas and others have a dropdown list.
Sheet 2 has columns A-P. I want to be able to paste the Sheet 1 data in Sheet 2-- The data generated as a result of formulas and drop downs. Also in a way, that if I change anything in Sheet 1 it changes on the other sheet. I want to be able to do this for multiple columns.
The thing is that Sheet 1 and Sheet 2 columns are not true to each other. I mean Column A of Sheet 1 is Column C in Sheet 2 etc..
Right now, I have simply equaled the cells using formula on both sheets to make this work. I don't wish to continue it this way. Macro will be better.
Thank you! Please help.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2")
hC = "AO"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:T"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range("C" & Lr).Value = Range("C" & R).Value
.Range("D" & Lr).Value = Range("D" & R).Value
.Range("E" & Lr).Value = Range("E" & R).Value
.Range("F" & Lr).Value = Range("F" & R).Value
.Range("G" & Lr).Value = Range("G" & R).Value
.Range("H" & Lr).Value = Range("H" & R).Value
.Range("I" & Lr).Value = Range("I" & R).Value
.Range("J" & Lr).Value = Range("J" & R).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("L" & Lr).Value = Range("K" & R).Value
.Range("M" & Lr).Value = Range("L" & R).Value
.Range("N" & Lr).Value = Range("M" & R).Value
.Range("O" & Lr).Value = Range("N" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
Edited Code (3_31_3017)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Route_Sheet")
hC = "AP"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:AL"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value
.Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range("Q" & Lr).Value = Range("U" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub

Answer 1

We need at least one thing to know that row(x) in Sheet 1 is related to row(y) in Sheet 2. this can be done by adding unique identifier for each row as #tigeravatar mentioned or by adding one formula in unused column in row(x) in Sheet 1 relating to row(y) in Sheet 2.
In Sheet 1 Module add this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2")
hC = "U" 'Change this to any unused column and You can hide it
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:T"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
' Add here all columns you need like :
'=====================================
.Range("C" & Lr).Value = Range("A" & R).Value
.Range("A" & Lr).Value = Range("B" & R).Value
'...etc
'=====================================
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
Edit:
Right click on "Master" sheet tab and select View Code and paste this code in it:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2") 'Change "Sheet 2" to your target sheet name like "Route_Sheet" or "Lists"
hC = "AO"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:AH"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row
If Not (Lr = 1 And .Range(hC & Lr).Value = vbNullString) Then Lr = Lr + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value
.Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
This is a Worksheet Event that run automatically when user change any cell inside Columns("A:AH").
If you want to run it manually you can add new sub in Module1:
Sub Test()
With sheets("Master").Range("A2:A50") ' change this range to all rows you need like "A5:A100"
.Value = .Value
End With
End Sub
Or:
Sub Test()
With Sheets("Master")
Application.Run .CodeName & ".Worksheet_Change", .Range("A1:A50") 'change this range to all rows you need like "A5:A100"
End With
End Sub