Macro to line up tables based on cell content

leroy79 · Jun 7, 2018

Hello, I am seeking assistance in writing a macro to help me line up data. The attached Excel file shows an example of what I have and what I want.

Columns A:C are from 2017. Columns D:F are from 2018, just pasted next to it. I have the same variables in each year (Variable1, Variable2, Variable3...) in the same order for each year.

The number of items in each table is not always the same. For example, 2017 Variable1 has "Yes". 2018 Variable1 has "Yes", "No". I want Variable2 to start on the same line.

I've searched many forums and found ways to line up individual rows, I'm not sure how to write the code so it will just line up that first row of the table. There are more than 100 tables, so inserting/deleting the rows manually isn't an option.

Thank you for your help!

Have:
2017		2018
Variable1	Percent	Variable1	Percent
Yes	100.00	Yes	95.24
		No	4.76190476
Variable2	Percent
Yes	0.28	Variable2	Percent
No	99.72	Yes	0.33
		No	94.9968334
Variable3	Percent	Maybe	5.14
Option 1	0.56
Option 2	99.4357296	Variable3	Percent
		Option 1	0.46
		Option 2	75.99
		Option 3	20.69
		Option 4	2.86
Want:
2017		2018
Variable1	Percent	Variable1	Percent
Yes	100.00	Yes	95.24
		No	4.76190476

Variable2	Percent	Variable2	Percent
Yes	0.28	Yes	0.33
No	99.72	No	94.9968334
		Maybe	5.14

Variable3	Percent	Variable3	Percent
Option 1	0.56	Option 1	0.46
Option 2	99.4357296	Option 2	75.99
		Option 3	20.69
		Option 4	2.86

MickG · Jun 9, 2018

Try this for results on sheet2.
NB:- If you Data is actual "Tables" , you may need to convert to Range!!

Code:

[COLOR=navy]Sub[/COLOR] MG09Jun01
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, Lst [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] R2 [COLOR=navy]As[/COLOR] Range, R1 [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] oMax [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] nRng [COLOR=navy]As[/COLOR] Range, Temp [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
    [COLOR=navy]Set[/COLOR] Rng = Range("D2", Range("D" & Rows.Count).End(xlUp))
        Lst = Rng.Count
    [COLOR=navy]Set[/COLOR] Rng = Rng.SpecialCells(xlCellTypeConstants)
        ReDim Ray(1 To Lst + 1, 1 To 6)
    [COLOR=navy]Set[/COLOR] nRng = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    c = 1
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] nRng.Areas
        Ray(1, 1) = nRng(1).Offset(-1).Value
            [COLOR=navy]If[/COLOR] Not .exists(Dn(1).Value) [COLOR=navy]Then[/COLOR]
                .Add Dn(1).Value, Dn
            [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng.Areas
        Ray(1, 4) = Rng(1).Offset(-1).Value
        
        [COLOR=navy]If[/COLOR] .exists(Dn(1).Value) [COLOR=navy]Then[/COLOR]
            Temp = c
            
            [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R2 [COLOR=navy]In[/COLOR] .Item(Dn(1).Value)
                c = c + 1
                Ray(c, 1) = R2: Ray(c, 2) = R2.Offset(, 1): Ray(c, 3) = R2.Offset(, 2)
            [COLOR=navy]Next[/COLOR] R2
            oMax = Application.Max(oMax, c)
                c = Temp
            [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] R1 [COLOR=navy]In[/COLOR] Dn
                c = c + 1
                Ray(c, 4) = R1: Ray(c, 5) = R1.Offset(, 1): Ray(c, 6) = R1.Offset(, 2)
            [COLOR=navy]Next[/COLOR] R1
                oMax = Application.Max(oMax, c)
                c = oMax + 1
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] With

[COLOR=navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c - 1, 6)
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

Jerry Sullivan · Jun 9, 2018

Here's another approach...

Code:

Sub AlignByHeaders()
 Dim bWrite1 As Boolean, bWrite2 As Boolean
 Dim lLastRow As Long, lNdxData1 As Long, lNdxData2 As Long, lNdxResult As Long
 Dim vData As Variant, vResult As Variant
 
 '--matching headers to align in columns 2 and 5
 Const sHEADER As String = "Percent"
 
 '--read data into array
 With ActiveSheet
   lLastRow = .Range("A:E").Find(What:="*", After:=Range("A1"), _
      SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
   vData = .Range("A1:E" & lLastRow)
 End With
 
 '--size results array
 ReDim vResult(1 To lLastRow * 2, 1 To 5)
 
 Do
   lNdxResult = lNdxResult + 1
   '--the row index gets incremented for each column unless
   '    the next row is Header for this col, but not the other side
   
   Select Case True
      Case vData(lNdxData1 + 1, 2) = sHEADER And vData(lNdxData2 + 1, 5) <> sHEADER
         bWrite1 = False: bWrite2 = True
      Case vData(lNdxData1 + 1, 2) <> sHEADER And vData(lNdxData2 + 1, 5) = sHEADER
         bWrite1 = True: bWrite2 = False
      Case Else
         bWrite1 = True: bWrite2 = True
   End Select

   '--write side 1
   If bWrite1 Then
      lNdxData1 = lNdxData1 + 1
      vResult(lNdxResult, 1) = vData(lNdxData1, 1)
      vResult(lNdxResult, 2) = vData(lNdxData1, 2)
   End If
   
   '--write 2
   If bWrite2 Then
      lNdxData2 = lNdxData2 + 1
      vResult(lNdxResult, 4) = vData(lNdxData2, 4)
      vResult(lNdxResult, 5) = vData(lNdxData2, 5)
   End If
 Loop While lNdxData1 < lLastRow And lNdxData2 < lLastRow
 
 With Sheets.Add
   .Cells(1).Resize(lNdxResult, UBound(vResult, 2)).Value = vResult
 End With
 
End Sub

leroy79 · Jun 11, 2018

Thank you for your help, this works great! How would I modify the code if I need to include additional columns? For example:

2017					2018
Variable1	Percent	Add'l Clmn3	Add'l Clmn4	Add'l Clmn5	Variable1	Percent	Add'l Clmn3	Add'l Clmn4	Add'l Clmn5
Yes	100				Yes	95.24
					No	4.7619
Variable2	Percent	Add'l Clmn3	Add'l Clmn4	Add'l Clmn5
Yes	0.28				Variable2	Percent	Add'l Clmn3	Add'l Clmn4	Add'l Clmn5
No	99.72				Yes	0.33
					No	94.9968
Variable3	Percent	Add'l Clmn3	Add'l Clmn4	Add'l Clmn5	Maybe	5.14
Option 1	0.56
Option 2	99.4357				Variable3	Percent	Add'l Clmn3	Add'l Clmn4	Add'l Clmn5
					Option 1	0.46
					Option 2	75.99
					Option 3	20.69
					Option 4	2.86

Jerry Sullivan · Jun 13, 2018

I can't tell from your response whether you are using Mick's code or mine. FWIW, I've generalized the code I suggested earlier so it can be adapted for different numbers of columns and relative position of the header to be matched.

Code:

Sub AlignByHeaders2()
 '--aligns two sets of adjacent columns by finding
 '    common column header for each group of rows

 Dim bWrite1 As Boolean, bWrite2 As Boolean
 Dim lLastRow As Long, lColCount As Long
 Dim lNdxCol, lNdxData1 As Long, lNdxData2 As Long, lNdxResult As Long
 Dim sTestSide1 As String, sTestSide2 As String
 Dim vData As Variant, vResult As Variant
 
 '--modify these variables based on layout
 Const sHEADER As String = "Percent"
 Const lCOL_PER_SIDE As Long = 6   'Column count per side
 Const lMATCH_COL As Long = 2 'Column Number to find sHeader for each side
 
 lColCount = lCOL_PER_SIDE * 2
 
 '--read data into array
 With ActiveSheet
   lLastRow = .Range("A:A").Resize(, lColCount).Find( _
      What:="*", After:=Range("A1"), _
      SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
   vData = .Range("A1").Resize(lLastRow, lColCount)
 End With
 
 '--size results array
 ReDim vResult(1 To lLastRow * 2, 1 To lColCount)
 
 Do
   lNdxResult = lNdxResult + 1
   
   '--read values from each side to be compared to sHeader
   sTestSide1 = vData(lNdxData1 + 1, lMATCH_COL)
   sTestSide2 = vData(lNdxData2 + 1, lMATCH_COL + lCOL_PER_SIDE)
      
   Select Case True
      '--the row index gets incremented for each column unless
      '    the next row is Header for this col, but not the other side
      Case sTestSide1 = sHEADER And sTestSide2 <> sHEADER
         bWrite1 = False: bWrite2 = True
      Case sTestSide1 <> sHEADER And sTestSide2 = sHEADER
         bWrite1 = True: bWrite2 = False
      Case Else
         bWrite1 = True: bWrite2 = True
   End Select

   '--write side 1
   If bWrite1 Then
      lNdxData1 = lNdxData1 + 1
      For lNdxCol = 1 To lCOL_PER_SIDE
         vResult(lNdxResult, lNdxCol) = vData(lNdxData1, lNdxCol)
      Next lNdxCol
   End If
   
   '--write 2
   If bWrite2 Then
      lNdxData2 = lNdxData2 + 1
      For lNdxCol = lCOL_PER_SIDE + 1 To lColCount
         vResult(lNdxResult, lNdxCol) = _
            vData(lNdxData2, lNdxCol)
      Next lNdxCol
   End If
   
 Loop While lNdxData1 < lLastRow And lNdxData2 < lLastRow
 
 With Sheets.Add
   .Cells(1).Resize(lNdxResult, UBound(vResult, 2)).Value = vResult
 End With
 
End Sub

leroy79 · Jun 13, 2018

Hi Jerry, Thank you very much for your help! I apologize for not specifying which method I was using (I was using yours). This has been extremely helpful!

If I can ask here, is there a way to add a simple boarder around each variable and data below it?

Thanks!

Macro to line up tables based on cell content

leroy79

New Member

Excel Facts

MickG

MrExcel MVP

Jerry Sullivan

MrExcel MVP

leroy79

New Member

Jerry Sullivan

MrExcel MVP

leroy79

New Member

Similar threads

Forum statistics

Share this page

Macro to line up tables based on cell content

leroy79

New Member

Excel Facts

MickG

MrExcel MVP

Jerry Sullivan

MrExcel MVP

leroy79

New Member

Jerry Sullivan

MrExcel MVP

leroy79

New 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