Need Macro Help to Match and Line Up Rows Among Three Sets of Data

jennifer865 · Jan 12, 2015

Hello! I am new to VBA and new to this forum! First off:

1. I am using Excel 2010.
2. I have a PC.

Ok, I have 3 sets of data and I need to sort, compare, and align.

Start

*	A	B	C	D	E	F	G	H	I	J	K
1	ASSET #	ASSET DESCRIPTION	COST	*	ASSET #	ASSET DESCRIPTION	COST	*	ASSET #	ASSET DESCRIPTION	COST
2	0001	WAREHOUSE	*10,000,000	*	0001	WAREHOUSE	*10,000,000	*	0006	YARD TRACTOR	* * * * *40,000
3	0014	SCISSOR LIFT	* * * * *10,000	*	0002	OFFICE BLDG	* *2,000,000	*	0007	FORKLIFT	* * * * *20,000
4	0004	14 ACRE CORP CAMPUS	* *5,000,000	*	0003	GARAGE	* *3,000,000	*	0008	CHEVY VAN	* * * * *20,000
5	0005	GMC PICKUP TRUCK	* * * * *20,000	*	0004	14 ACRE CORP CAMPUS	* *5,000,000	*	0012	COPIER	* * * * * *1,000
6	0006	YARD TRACTOR	* * * * *40,000	*	0005	GMC PICKUP TRUCK	* * * * *20,000	*	0014	SCISSOR LIFT	* * * * *10,000
7	0007	FORKLIFT	* * * * *20,000	*	0006	YARD TRACTOR	* * * * *40,000	*	0001	WAREHOUSE	*10,000,000
8	0002	OFFICE BLDG	* *2,000,000	*	0007	FORKLIFT	* * * * *20,000	*	0002	OFFICE BLDG	* *2,000,000
9	0003	GARAGE	* *3,000,000	*	0008	CHEVY VAN	* * * * *20,000	*	0003	GARAGE	* *3,000,000
10	0008	CHEVY VAN	* * * * *20,000	*	0009	CONFERENCE DESK	* * * * * *1,000	*	0004	14 ACRE CORP CAMPUS	* *5,000,000
11	0009	CONFERENCE DESK	* * * * * *1,000	*	0010	PHONE SYSTEM	* * * * * *2,000	*	0005	GMC PICKUP TRUCK	* * * * *20,000
12	0010	PHONE SYSTEM	* * * * * *2,000	*	0012	COPIER	* * * * * *1,000	*	0009	CONFERENCE DESK	* * * * * *1,000
13	0011	REFRIGERATOR	* * * * * *1,000	*	0013	MERCHANDISE PICKER	*10,000,000	*	0013	MERCHANDISE PICKER	*10,000,000
14	0012	COPIER	* * * * * *1,000	*	0014	SCISSOR LIFT	* * * * *10,000	*	0017	DELL 300	* * * * * *1,000
15	0013	MERCHANDISE PICKER	*10,000,000	*	0015	LABEL READER	* * * *100,000	*	*	*	*
16	0015	LABEL READER	* * * *100,000	*	0017	DELL 300	* * * * * *1,000	*	*	*	*
17	0016	CONVEYOR	* *1,000,000	*	0018	INTEL SPIRON	* * * * * *1,000	*	*	*	*
18	0020	PACKER SOFTWARE UPGARDE	* * * * * *3,000	*	*	*	*	*	*	*	*
19	0018	INTEL SPIRON	* * * * * *1,000	*	*	*	*	*	*	*	*
20	0017	DELL 300	* * * * * *1,000	*	*	*	*	*	*	*	*

Excel tables to the web >> Excel Jeanie HTML 4

In the above, Set 1 is shown in Columns A-C, Set 2 is in E-G, and Set 3 is in I-K. What I need the macro to do is sort Set 1 by Column A (Asset #) in ascending order. Then, go to Set 2, sort by Column E (Asset #) and match line by line with Set 1, leaving blank lines if an Asset # is not found. Finally, go to Set 3, sort by Column I and match line by line, again leaving blank lines if an Asset # is not found. The final product will look like this:

End

*	A	B	C	D	E	F	G	H	I	J	K
1	ASSET #	ASSET DESCRIPTION	COST	*	ASSET #	ASSET DESCRIPTION	COST	*	ASSET #	ASSET DESCRIPTION	COST
2	0001	WAREHOUSE	*10,000,000	*	0001	WAREHOUSE	*10,000,000	*	0001	WAREHOUSE	*10,000,000
3	0002	OFFICE BLDG	* *2,000,000	*	0002	OFFICE BLDG	* *2,000,000	*	0002	OFFICE BLDG	* *2,000,000
4	0003	GARAGE	* *3,000,000	*	0003	GARAGE	* *3,000,000	*	0003	GARAGE	* *3,000,000
5	0004	14 ACRE CORP CAMPUS	* *5,000,000	*	0004	14 ACRE CORP CAMPUS	* *5,000,000	*	0004	14 ACRE CORP CAMPUS	* *5,000,000
6	0005	GMC PICKUP TRUCK	* * * * *20,000	*	0005	GMC PICKUP TRUCK	* * * * *20,000	*	0005	GMC PICKUP TRUCK	* * * * *20,000
7	0006	YARD TRACTOR	* * * * *40,000	*	0006	YARD TRACTOR	* * * * *40,000	*	0006	YARD TRACTOR	* * * * *40,000
8	0007	FORKLIFT	* * * * *20,000	*	0007	FORKLIFT	* * * * *20,000	*	0007	FORKLIFT	* * * * *20,000
9	0008	CHEVY VAN	* * * * *20,000	*	0008	CHEVY VAN	* * * * *20,000	*	0008	CHEVY VAN	* * * * *20,000
10	0009	CONFERENCE DESK	* * * * * *1,000	*	0009	CONFERENCE DESK	* * * * * *1,000	*	0009	CONFERENCE DESK	* * * * * *1,000
11	0010	PHONE SYSTEM	* * * * * *2,000	*	0010	PHONE SYSTEM	* * * * * *2,000	*	*	*	*
12	0011	REFRIGERATOR	* * * * * *1,000	*	*	*	*	*	*	*	*
13	0012	COPIER	* * * * * *1,000	*	0012	COPIER	* * * * * *1,000	*	0012	COPIER	* * * * * *1,000
14	0013	MERCHANDISE PICKER	*10,000,000	*	0013	MERCHANDISE PICKER	*10,000,000	*	0013	MERCHANDISE PICKER	*10,000,000
15	0014	SCISSOR LIFT	* * * * *10,000	*	0014	SCISSOR LIFT	* * * * *10,000	*	0014	SCISSOR LIFT	* * * * *10,000
16	0015	LABEL READER	* * * *100,000	*	0015	LABEL READER	* * * *100,000	*	*	*	*
17	0016	CONVEYOR	* *1,000,000	*	*	*	*	*	*	*	*
18	0017	DELL 300	* * * * * *1,000	*	0017	DELL 300	* * * * * *1,000	*	0017	DELL 300	* * * * * *1,000
19	0018	INTEL SPIRON	* * * * * *1,000	*	0018	INTEL SPIRON	* * * * * *1,000	*	*	*	*
20	0019	PACKER II SOFTWARE	* * * * * *5,000	*	*	*	*	*	*	*	*
21	0020	PACKER SOFTWARE UPGARDE	* * * * * *3,000	*	*	*	*	*	*	*	*

Excel tables to the web >> Excel Jeanie HTML 4

Your help is much appreciated!

JLGWhiz · Jan 12, 2015

See if this will work.

Code:

Sub alignStuff()
Dim sh As Worksheet, lr As Long, rng1 As Range, rng2 As Range, rng3 As Range, fLoc As Range
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
Set rng1 = sh.Range("A2:C" & lr)
rng1.Sort sh.Range("A2"), xlAscending
sh.Range("E:K").EntireColumn.Insert
Set rng2 = sh.Range("L2:N" & lr)
Set rng3 = sh.Range("P2:R" & lr)
    For i = lr To 2 Step -1
        With sh
            Set fLoc = rng2.Find(.Cells(i, 1).Value, , xlValues, xlWhole)
                If Not fLoc Is Nothing Then
                    fLoc.Resize(1, 3).Cut .Cells(i, 5)
                End If
            Set fLoc = Nothing
            Set fLoc = rng3.Find(.Cells(i, 1).Value, , xlValues, xlWhole)
                If Not fLoc Is Nothing Then
                    fLoc.Resize(1, 3).Cut .Cells(i, 9)
                End If
            Set fLoc = Nothing
        End With
    Next
    sh.Range("L1:R1").Cut sh.Range("E1")
    sh.Range("E1:K1").EntireColumn.AutoFit
    sh.Range("L1:R1").EntireColumn.Delete
End Sub

hiker95 · Jan 12, 2015

jennifer865,

Thanks for the Private Message, and, the new raw data.

Sample raw data in worksheet Sheet1 (if the worksheet name is different, then I can change the sheet name in the macro):

Excel 2007

A

B

C

D

E

F

G

H

I

J

K

1

ASSET #

ASSET DESCRIPTION

COST

ASSET #

ASSET DESCRIPTION

COST

ASSET #

ASSET DESCRIPTION

COST

2

1

WAREHOUSE

10,000,000

1

WAREHOUSE

10,000,000

6

YARD TRACTOR

40,000

3

14

SCISSOR LIFT

10,000

2

OFFICE BLDG

2,000,000

7

FORKLIFT

20,000

4

14 ACRE CORP CAMPUS

5,000,000

3

GARAGE

3,000,000

8

CHEVY VAN

20,000

5

GMC PICKUP TRUCK

20,000

4

14 ACRE CORP CAMPUS

5,000,000

12

COPIER

1,000

6

YARD TRACTOR

40,000

5

GMC PICKUP TRUCK

20,000

14

SCISSOR LIFT

10,000

7

FORKLIFT

20,000

6

YARD TRACTOR

40,000

1

WAREHOUSE

10,000,000

8

2

OFFICE BLDG

2,000,000

7

FORKLIFT

20,000

2

OFFICE BLDG

2,000,000

9

3

GARAGE

3,000,000

8

CHEVY VAN

20,000

3

GARAGE

3,000,000

10

8

CHEVY VAN

20,000

9

CONFERENCE DESK

1,000

4

14 ACRE CORP CAMPUS

5,000,000

11

9

CONFERENCE DESK

1,000

10

PHONE SYSTEM

2,000

5

GMC PICKUP TRUCK

20,000

12

10

PHONE SYSTEM

2,000

12

COPIER

1,000

9

CONFERENCE DESK

1,000

13

11

REFRIGERATOR

1,000

13

MERCHANDISE PICKER

10,000,000

13

MERCHANDISE PICKER

10,000,000

14

12

COPIER

1,000

14

SCISSOR LIFT

10,000

17

DELL 300

1,000

15

13

MERCHANDISE PICKER

10,000,000

15

LABEL READER

100,000

16

15

LABEL READER

100,000

17

DELL 300

1,000

17

16

CONVEYOR

1,000,000

18

INTEL SPIRON

1,000

18

20

PACKER SOFTWARE UPGARDE

3,000

19

18

INTEL SPIRON

1,000

20

17

DELL 300

1,000

21

Sheet1

After the macro:

Excel 2007

A

B

C

D

E

F

G

H

I

J

K

1

ASSET #

ASSET DESCRIPTION

COST

ASSET #

ASSET DESCRIPTION

COST

ASSET #

ASSET DESCRIPTION

COST

2

1

WAREHOUSE

10,000,000

1

WAREHOUSE

10,000,000

1

WAREHOUSE

10,000,000

3

2

OFFICE BLDG

2,000,000

2

OFFICE BLDG

2,000,000

2

OFFICE BLDG

2,000,000

4

3

GARAGE

3,000,000

3

GARAGE

3,000,000

3

GARAGE

3,000,000

5

4

14 ACRE CORP CAMPUS

5,000,000

4

14 ACRE CORP CAMPUS

5,000,000

4

14 ACRE CORP CAMPUS

5,000,000

6

5

GMC PICKUP TRUCK

20,000

5

GMC PICKUP TRUCK

20,000

5

GMC PICKUP TRUCK

20,000

7

6

YARD TRACTOR

40,000

6

YARD TRACTOR

40,000

6

YARD TRACTOR

40,000

8

7

FORKLIFT

20,000

7

FORKLIFT

20,000

7

FORKLIFT

20,000

9

8

CHEVY VAN

20,000

8

CHEVY VAN

20,000

8

CHEVY VAN

20,000

10

9

CONFERENCE DESK

1,000

9

CONFERENCE DESK

1,000

9

CONFERENCE DESK

1,000

11

10

PHONE SYSTEM

2,000

10

PHONE SYSTEM

2,000

12

11

REFRIGERATOR

1,000

13

12

COPIER

1,000

12

COPIER

1,000

12

COPIER

1,000

14

13

MERCHANDISE PICKER

10,000,000

13

MERCHANDISE PICKER

10,000,000

13

MERCHANDISE PICKER

10,000,000

15

14

SCISSOR LIFT

10,000

14

SCISSOR LIFT

10,000

14

SCISSOR LIFT

10,000

16

15

LABEL READER

100,000

15

LABEL READER

100,000

17

16

CONVEYOR

1,000,000

18

17

DELL 300

1,000

17

DELL 300

1,000

17

DELL 300

1,000

19

18

INTEL SPIRON

1,000

18

INTEL SPIRON

1,000

20

PACKER SOFTWARE UPGARDE

3,000

21

Sheet1

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
2. Open your NEW 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
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code:

Sub AlignASSETnbrs()
' hiker95, 01/12/2015, ME828545
Dim a As Variant, e As Variant, i As Variant, o As Variant
Dim lra As Long, lre As Long, lri As Long, lur As Long, n As Long, j As Long
Dim rnga As Range, rnge As Range, rngi As Range, c As Range, m As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
  lra = .Cells(Rows.Count, "A").End(xlUp).Row
  .Range("A2:C" & lra).Sort key1:=.Range("A2"), order1:=1
  a = .Range("A2:C" & lra)
  Set rnga = .Range("A2:A" & lra)
  lre = .Cells(Rows.Count, "E").End(xlUp).Row
  .Range("E2:G" & lre).Sort key1:=.Range("E2"), order1:=1
  e = .Range("E2:G" & lre)
  Set rnge = .Range("E2:E" & lre)
  lri = .Cells(Rows.Count, "I").End(xlUp).Row
  .Range("I2:K" & lri).Sort key1:=.Range("I2"), order1:=1
  i = .Range("I2:K" & lri)
  Set rngi = .Range("I2:I" & lri)
  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each c In rnga
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    For Each c In rnge
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    For Each c In rngi
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    o = Application.Transpose(Array(.Keys))
    n = .Count
  End With
  .Columns(13).ClearContents
  .Cells(2, 13).Resize(n).Value = o
  .Range("M2:M" & n).Sort key1:=.Range("M1"), order1:=1
  .Range("A2:C" & lra).ClearContents
  .Range("E2:G" & lre).ClearContents
  .Range("I2:K" & lri).ClearContents
  For j = 1 To UBound(a, 1)
    Set m = Columns(13).Find(a(j, 1), LookAt:=xlWhole)
    If Not m Is Nothing Then
      .Cells(m.Row, 1) = a(j, 1)
      .Cells(m.Row, 2) = a(j, 2)
      .Cells(m.Row, 3) = a(j, 3)
    End If
  Next j
  For j = 1 To UBound(e, 1)
    Set m = .Columns(13).Find(e(j, 1), LookAt:=xlWhole)
    If Not m Is Nothing Then
      .Cells(m.Row, 5) = e(j, 1)
      .Cells(m.Row, 6) = e(j, 2)
      .Cells(m.Row, 7) = e(j, 3)
    End If
  Next j
  For j = 1 To UBound(i, 1)
    Set m = .Columns(13).Find(i(j, 1), LookAt:=xlWhole)
    If Not m Is Nothing Then
      .Cells(m.Row, 9) = i(j, 1)
      .Cells(m.Row, 10) = i(j, 2)
      .Cells(m.Row, 11) = i(j, 3)
    End If
  Next j
  .Columns(13).ClearContents
  lur = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  .Range("C2:C" & lur).NumberFormat = "#,##0"
  .Range("G2:G" & lur).NumberFormat = "#,##0"
  .Range("K2:K" & lur).NumberFormat = "#,##0"
End With
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 AlignASSETnbrs macro.

hiker95 · Jan 13, 2015

jennifer865,

The following macro is based on your other thread reply, requesting totals.

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).

Code:

Sub AlignASSETnbrsWithTotals()
' hiker95, 01/13/2015, ME828545
Dim a As Variant, e As Variant, i As Variant, o As Variant
Dim lra As Long, lre As Long, lri As Long, lur As Long, n As Long, j As Long
Dim rnga As Range, rnge As Range, rngi As Range, c As Range, m As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
  lra = .Cells(Rows.Count, "A").End(xlUp).Row
  .Range("A2:C" & lra).Sort key1:=.Range("A2"), order1:=1
  a = .Range("A2:C" & lra)
  Set rnga = .Range("A2:A" & lra)
  lre = .Cells(Rows.Count, "E").End(xlUp).Row
  .Range("E2:G" & lre).Sort key1:=.Range("E2"), order1:=1
  e = .Range("E2:G" & lre)
  Set rnge = .Range("E2:E" & lre)
  lri = .Cells(Rows.Count, "I").End(xlUp).Row
  .Range("I2:K" & lri).Sort key1:=.Range("I2"), order1:=1
  i = .Range("I2:K" & lri)
  Set rngi = .Range("I2:I" & lri)
  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each c In rnga
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    For Each c In rnge
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    For Each c In rngi
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    o = Application.Transpose(Array(.Keys))
    n = .Count
  End With
  .Columns(13).ClearContents
  .Cells(2, 13).Resize(n).Value = o
  .Range("M2:M" & n).Sort key1:=.Range("M1"), order1:=1
  .Range("A2:C" & lra).ClearContents
  .Range("E2:G" & lre).ClearContents
  .Range("I2:K" & lri).ClearContents
  For j = 1 To UBound(a, 1)
    Set m = Columns(13).Find(a(j, 1), LookAt:=xlWhole)
    If Not m Is Nothing Then
      .Cells(m.Row, 1) = a(j, 1)
      .Cells(m.Row, 2) = a(j, 2)
      .Cells(m.Row, 3) = a(j, 3)
    End If
  Next j
  For j = 1 To UBound(e, 1)
    Set m = .Columns(13).Find(e(j, 1), LookAt:=xlWhole)
    If Not m Is Nothing Then
      .Cells(m.Row, 5) = e(j, 1)
      .Cells(m.Row, 6) = e(j, 2)
      .Cells(m.Row, 7) = e(j, 3)
    End If
  Next j
  For j = 1 To UBound(i, 1)
    Set m = .Columns(13).Find(i(j, 1), LookAt:=xlWhole)
    If Not m Is Nothing Then
      .Cells(m.Row, 9) = i(j, 1)
      .Cells(m.Row, 10) = i(j, 2)
      .Cells(m.Row, 11) = i(j, 3)
    End If
  Next j
  .Columns(13).ClearContents
  lur = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  .Cells(lur + 2, 2) = "Total": .Cells(lur + 2, 3).Formula = "=SUM(C2:C" & lur & ")"
  .Cells(lur + 2, 6) = "Total": .Cells(lur + 2, 7).Formula = "=SUM(G2:G" & lur & ")"
  .Cells(lur + 2, 10) = "Total": .Cells(lur + 2, 11).Formula = "=SUM(K2:K" & lur & ")"
  .Range("C2:C" & lur + 2).NumberFormat = "#,##0"
  .Range("G2:G" & lur + 2).NumberFormat = "#,##0"
  .Range("K2:K" & lur + 2).NumberFormat = "#,##0"
End With
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 AlignASSETnbrsWithTotals macro.

jennifer865 · Jan 13, 2015

Mind = blown! This works perfectly!

Will this particular macro only work if the Asset # is in number format or will it also work if the Asset # is in text format (ie with leading zeroes)?

Thanks again for all of your hard work!

hiker95 · Jan 13, 2015

jennifer865,

Mind = blown! This works perfectly! ... Thanks again for all of your hard work!

Thanks for the feedback.

You are very welcome. Glad I could help.

Will this particular macro only work if the Asset # is in number format or will it also work if the Asset # is in text format (ie with leading zeroes)?

Good question. I would have to see the new raw data, and, what the results should look like.

You have been using Excel Jeanie. Have you looked at your screenshots? There are * characters in empty cells. I think that you may have a space character in the blank cells. In order to use your screenshots I had to remove the * characters manually. And, that is no fun.

I did use Excel Jeanie back when. But, I now use the MrExcel HTML Maker.

Could you try using the MrExcel HTML Maker?

Or, even better:

You can upload your workbook to Box Net,

sensitive data changed

mark the workbook for sharing

and provide us with a link to your workbook.

jennifer865 · Jan 27, 2015

Hi Hiker95,

You created the above macro for me a couple of weeks ago to help match and line up 3 sets of data. The macro you created for me worked perfectly with the data sets I gave you, but now my source data has changed. I tried to modify the macro to conform to the new data sets, but no such luck. I have uploaded by workbook to BoxNet, you can find it here: https://app.box.com/s/uwqhsv17n4e7s5wnkgc1hsxobkbwrb04

The basic premise is still the same: there are 3 sets of data of variable lengths that need to be matched and lined up by a common attribute - in this case "Asset#." The positioning of the data changed slightly - from data starting in A2 to data starting in A14. Also, where my original data sets only had 3 columns per set, the new data sets have 6 columns each.

The other change is that after the data sets are matched, if there is a blank field in Column A (Data Set 1 - "Description"), then whatever values is in Data Set 2 (or 3) should be copied and pasted into Column A. This will be much better explained when you see the example workbook.

Sheet 1 is the raw data, and Sheet 2 is how I want it to look after the macro is run. There are text boxes on each sheet to further explain what I need.

Thank you in advance for your help! It is most appreciated.

hiker95 · Jan 27, 2015

jennifer865,

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).

Code:

Sub AlignASSETnbrsWithTotals_V2()
' hiker95, 01/27/2015, ME828545
Dim a As Variant, h As Variant, o As Variant, out As Variant
Dim lrb As Long, lri As Long, lrp As Long, lur As Long, n As Long, j As Long
Dim rngb As Range, rngi As Range, rngp As Range, c As Range, u As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
  lrb = .Cells(Rows.Count, "B").End(xlUp).Row
  .Range("A14:F" & lrb).Sort key1:=.Range("B14"), order1:=1
  a = .Range("A14:F" & lrb)
  Set rngb = .Range("B14:B" & lrb)
  lri = .Cells(Rows.Count, "I").End(xlUp).Row
  .Range("H14:M" & lri).Sort key1:=.Range("I14"), order1:=1
  h = .Range("H2:M" & lri)
  Set rngi = .Range("I14:I" & lri)
  lrp = .Cells(Rows.Count, "P").End(xlUp).Row
  .Range("O14:T" & lrp).Sort key1:=.Range("P14"), order1:=1
  o = .Range("O14:T" & lrp)
  Set rngp = .Range("P14:P" & lrp)
  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each c In rngb
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    For Each c In rngi
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    For Each c In rngp
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    out = Application.Transpose(Array(.Keys))
    n = .Count
End With
  .Columns(21).ClearContents
  .Cells(14, 21).Resize(n).Value = out
  .Range("U14:U" & n).Sort key1:=.Range("U14"), order1:=1
  .Range("A14:F" & lrb).ClearContents
  .Range("H14:M" & lri).ClearContents
  .Range("O14:T" & lrp).ClearContents
  For j = 1 To UBound(a, 1)
    Set u = .Columns(21).Find(a(j, 2), LookAt:=xlWhole)
    If Not u Is Nothing Then
      .Cells(u.Row, 1) = a(j, 1)
      .Cells(u.Row, 2) = a(j, 2)
      .Cells(u.Row, 3) = a(j, 3)
      .Cells(u.Row, 4) = a(j, 4)
      .Cells(u.Row, 5) = a(j, 5)
      .Cells(u.Row, 6) = a(j, 6)
    End If
  Next j
  For j = 1 To UBound(h, 1)
    Set u = .Columns(21).Find(h(j, 2), LookAt:=xlWhole)
    If Not u Is Nothing Then
      .Cells(u.Row, 8) = h(j, 1)
      .Cells(u.Row, 9) = h(j, 2)
      .Cells(u.Row, 10) = h(j, 3)
      .Cells(u.Row, 11) = h(j, 4)
      .Cells(u.Row, 12) = h(j, 5)
      .Cells(u.Row, 13) = h(j, 6)
    End If
  Next j
  For j = 1 To UBound(o, 1)
    Set u = .Columns(21).Find(o(j, 2), LookAt:=xlWhole)
    If Not u Is Nothing Then
      .Cells(u.Row, 15) = a(j, 1)
      .Cells(u.Row, 16) = a(j, 2)
      .Cells(u.Row, 17) = a(j, 3)
      .Cells(u.Row, 18) = a(j, 4)
      .Cells(u.Row, 19) = a(j, 5)
      .Cells(u.Row, 20) = a(j, 6)
    End If
  Next j
  .Columns(21).ClearContents
  lur = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  With .Cells(lur + 2, 1)
    .Value = "TOTALS"
    .Font.Bold = True
  End With
  With .Cells(lur + 2, 6)
    .Formula = "=SUM(F14:F" & lur & ")"
    .Font.Bold = True
  End With
  With .Cells(lur + 2, 13)
    .Formula = "=SUM(M14:M" & lur & ")"
    .Font.Bold = True
  End With
  With .Cells(lur + 2, 20)
    .Formula = "=SUM(T14:T" & lur & ")"
    .Font.Bold = True
  End With
  .Range("F14:F" & lur + 2).NumberFormat = "#,##0"
  .Range("M14:M" & lur + 2).NumberFormat = "#,##0"
  .Range("T14:T" & lur + 2).NumberFormat = "#,##0"
End With
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 AlignASSETnbrsWithTotals_V2 macro.

jennifer865 · Jan 27, 2015

hiker95 said:

jennifer865,

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).

Code:

Sub AlignASSETnbrsWithTotals_V2()
' hiker95, 01/27/2015, ME828545
Dim a As Variant, h As Variant, o As Variant, out As Variant
Dim lrb As Long, lri As Long, lrp As Long, lur As Long, n As Long, j As Long
Dim rngb As Range, rngi As Range, rngp As Range, c As Range, u As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
  lrb = .Cells(Rows.Count, "B").End(xlUp).Row
  .Range("A14:F" & lrb).Sort key1:=.Range("B14"), order1:=1
  a = .Range("A14:F" & lrb)
  Set rngb = .Range("B14:B" & lrb)
  lri = .Cells(Rows.Count, "I").End(xlUp).Row
  .Range("H14:M" & lri).Sort key1:=.Range("I14"), order1:=1
  h = .Range("H2:M" & lri)
  Set rngi = .Range("I14:I" & lri)
  lrp = .Cells(Rows.Count, "P").End(xlUp).Row
  .Range("O14:T" & lrp).Sort key1:=.Range("P14"), order1:=1
  o = .Range("O14:T" & lrp)
  Set rngp = .Range("P14:P" & lrp)
  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each c In rngb
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    For Each c In rngi
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    For Each c In rngp
      If c <> "" Then
        If Not .Exists(c.Value) Then
          .Add c.Value, c.Value
        End If
      End If
    Next
    out = Application.Transpose(Array(.Keys))
    n = .Count
End With
  .Columns(21).ClearContents
  .Cells(14, 21).Resize(n).Value = out
  .Range("U14:U" & n).Sort key1:=.Range("U14"), order1:=1
  .Range("A14:F" & lrb).ClearContents
  .Range("H14:M" & lri).ClearContents
  .Range("O14:T" & lrp).ClearContents
  For j = 1 To UBound(a, 1)
    Set u = .Columns(21).Find(a(j, 2), LookAt:=xlWhole)
    If Not u Is Nothing Then
      .Cells(u.Row, 1) = a(j, 1)
      .Cells(u.Row, 2) = a(j, 2)
      .Cells(u.Row, 3) = a(j, 3)
      .Cells(u.Row, 4) = a(j, 4)
      .Cells(u.Row, 5) = a(j, 5)
      .Cells(u.Row, 6) = a(j, 6)
    End If
  Next j
  For j = 1 To UBound(h, 1)
    Set u = .Columns(21).Find(h(j, 2), LookAt:=xlWhole)
    If Not u Is Nothing Then
      .Cells(u.Row, 8) = h(j, 1)
      .Cells(u.Row, 9) = h(j, 2)
      .Cells(u.Row, 10) = h(j, 3)
      .Cells(u.Row, 11) = h(j, 4)
      .Cells(u.Row, 12) = h(j, 5)
      .Cells(u.Row, 13) = h(j, 6)
    End If
  Next j
  For j = 1 To UBound(o, 1)
    Set u = .Columns(21).Find(o(j, 2), LookAt:=xlWhole)
    If Not u Is Nothing Then
      .Cells(u.Row, 15) = a(j, 1)
      .Cells(u.Row, 16) = a(j, 2)
      .Cells(u.Row, 17) = a(j, 3)
      .Cells(u.Row, 18) = a(j, 4)
      .Cells(u.Row, 19) = a(j, 5)
      .Cells(u.Row, 20) = a(j, 6)
    End If
  Next j
  .Columns(21).ClearContents
  lur = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  With .Cells(lur + 2, 1)
    .Value = "TOTALS"
    .Font.Bold = True
  End With
  With .Cells(lur + 2, 6)
    .Formula = "=SUM(F14:F" & lur & ")"
    .Font.Bold = True
  End With
  With .Cells(lur + 2, 13)
    .Formula = "=SUM(M14:M" & lur & ")"
    .Font.Bold = True
  End With
  With .Cells(lur + 2, 20)
    .Formula = "=SUM(T14:T" & lur & ")"
    .Font.Bold = True
  End With
  .Range("F14:F" & lur + 2).NumberFormat = "#,##0"
  .Range("M14:M" & lur + 2).NumberFormat = "#,##0"
  .Range("T14:T" & lur + 2).NumberFormat = "#,##0"
End With
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 AlignASSETnbrsWithTotals_V2 macro.

Thanks for the fast response!

I've uploaded my updated workbook to BoxNet. Sheet 3 shows how the data appears after I ran the macro. https://app.box.com/s/7nvcr3qp7mvsjih1yeib6nqula0v6kq0

Ok, so Data Set 1 and 2 look great. Data Set 3 seems to go off the rails a bit...the first two rows of Data Set 3 match Sets 1 & 2, but after that they do not. Also, it looks like some rows were added to Data Set 3 after the macro was run that were not in the original Data Set. For example, there should not be any year entries (Column R) in Data Set 3 that are greater than 2010.

Let me know if you have any questions, and thanks again!

hiker95 · Jan 27, 2015

jennifer865,

We have done this exercise several times (and, in two different threads), and, each time I have used the Scripting.Dictionary to get a unique list of Asset #'s.

Here is the way the AlignASSETnbrsWithTotals_V2 macro works with the Scripting.Dictionary:

1. it gets all the unique Asset #'s from B14, down. If any cell is blank, it does not record it, because it is BLANK.

2. it gets all the unique Asset #'s from I14, down. If any cell is blank, it does not record it, because it is BLANK.

3. it gets all the unique Asset #'s from P14, down. If any cell is blank, it does not record it, because it is BLANK.

I have far exceeded the normal amount of time I allocate for solving problems/requests from web sites like MrExcel.

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.

Need Macro Help to Match and Line Up Rows Among Three Sets of Data

jennifer865

New Member

Excel Facts

JLGWhiz

Well-known Member

hiker95

Well-known Member

hiker95

Well-known Member

jennifer865

New Member

hiker95

Well-known Member

jennifer865

New Member

hiker95

Well-known Member

jennifer865

New Member

hiker95

Well-known Member

Similar threads

Forum statistics

Share this page

Need Macro Help to Match and Line Up Rows Among Three Sets of Data

New Member

Excel Facts

Well-known Member

Well-known Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock