Matching Cells from two seperate sheets of excel data while creating a third sheet

TobyJoel,


Detach/open workbook AlignLists w1 w2 to wR - TobyJoel - EF871565 - SDG15.xlsm and run the AlignLists macro.



With the prior years data in Sheet1, and the current years data in Sheet2. The macro will create a new worksheet Results, with the data aligned and formulae inserted.


If you want to use the macro on another workbook:


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub AlignLists()
' stanleydgromjr, 10/26/2012
' http://www.excelforum.com/excel-programming-vba-macros/871565-matching-cells-from-two-seperate-sheets-of-excel-data-while-creating-a-third-sheet.html
Dim w1 As Worksheet, w2 As Worksheet, wR As Worksheet
Dim r As Long, lr As Long, d As Range
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
Set w2 = Worksheets("Sheet2")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w2).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
lr = w1.Cells(Rows.Count, 1).End(xlUp).Row
w1.Range("A1:K" & lr).Copy wR.Cells(1, 2)
lr = w2.Cells(Rows.Count, 1).End(xlUp).Row
w2.Range("A1:K" & lr).Copy wR.Cells(1, 15)
lr = wR.Cells(Rows.Count, 2).End(xlUp).Row
With wR.Range("A2:A" & lr)
  .FormulaR1C1 = "=RC[1]&RC[2]"
  .Value = .Value
End With
lr = wR.Cells(Rows.Count, 15).End(xlUp).Row
With wR.Range("N2:N" & lr)
  .FormulaR1C1 = "=RC[1]&RC[2]"
  .Value = .Value
End With
lr = wR.Cells(Rows.Count, 1).End(xlUp).Row
wR.Range("A2:L" & lr).Sort key1:=wR.Range("A2"), order1:=1
lr = wR.Cells(Rows.Count, 14).End(xlUp).Row
wR.Range("N2:Y" & lr).Sort key1:=wR.Range("N2"), order1:=1
lr = wR.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
Set d = Range("A1:A" & lr)
r = 2
Do While d.Cells(r, 1) <> ""
  If d.Cells(r, 1).Offset(, 13) <> "" Then
    If d.Cells(r, 1) < d.Cells(r, 1).Offset(, 13) Then
      d.Cells(r, 1).Offset(, 13).Resize(, 12).Insert -4121
    ElseIf d.Cells(r, 1) > d.Cells(r, 1).Offset(, 13) Then
      d.Cells(r, 1).Resize(, 12).Insert -4121
      lr = lr + 1
      Set d = Range("A1:A" & lr)
    End If
  End If
  r = r + 1
Loop
wR.Columns(1).Delete
wR.Columns("L:M").ClearContents
lr = wR.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
wR.Range("L2:L" & lr).FormulaR1C1 = "=EXACT(RC[-10],RC[3])"
With wR.Range("M2:M" & lr)
  .FormulaR1C1 = "=RC[9]/RC[-4]"
  .NumberFormat = "0.00%"
End With
wR.Cells.EntireColumn.HorizontalAlignment = xlCenter
wR.Cells.EntireColumn.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the AlignLists macro.

Thank you Stan. This worked perfectly! I appreciate the help and the quick reply.
-Toby

TobyJoel,

You are very welcome. Glad I could help.

Thanks for the feedback.

Come back anytime.