Line Up Data Rows in Columns of Varying Lengths where Blanks Are Added when a Match Is Not Found

[Beowulf891]

Greetings. I currently find myself with an Excel problem that I just can't seem to solve. I have two result sets I need to compare item quantities against. I have four columns, two columns per result set. The first is a unique product ID and the second is the quantity for that item. I need the result sets to be of equal column length, filling in blank information when no match is found. I have found a few solutions, but they have, so far, not worked the way I need them to.

Option Explicit

Sub LineEmUp4()
'Author:    Jerry Beaucaire
'Date:      7/12/2011
'Summary:   Line up a random number of paired columns so all matching
'           items are on the same rows, matches are in odd numbered columns
Dim LR     As Long
Dim FR     As Long
Dim LC     As Long
Dim Col    As Long
Dim SrtCol As Long
Dim Cols   As Long
Dim Hdrs   As Long
Dim off    As Boolean
Dim vFND   As Range
Dim vRNG   As Range
Dim v      As Range

'Ask how many columns go together
    Cols = Application.InputBox("How many columns go together in groups?", "Column Groups", 2, Type:=1)
    If Cols = 0 Then Exit Sub
   
'Ask if headers exist
    Hdrs = MsgBox("Does the first row contain column headers? (No means row 1 is data, too.)", vbYesNo, "Headers")
   
'Spot last column of data and check the grouping
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
    If LC Mod Cols <> 0 Then
        MsgBox "The number of data columns does not match grouping, please check your data."
        Exit Sub
    End If
   
'Indicate how to sort the data groups, column must be the same in each group
    Do
        SrtCol = Application.InputBox("Within each group of " & Cols & " columns, which column should the data be matched by?", _
            "Match Column", 1, Type:=1)
        If SrtCol <= Cols And SrtCol > 0 Then Exit Do
        If MsgBox("The column groups do not have that many columns, try again?", _
            vbYesNo, "Retry?") = vbNo Then Exit Sub
    Loop
           
    Application.ScreenUpdating = False

'Sort all groups to get them ascending properly
    For Col = 1 To LC Step Cols
        If Hdrs = 6 Then
            Columns(Col).Resize(, Cols).Sort Key1:=Cells(2, Col - 1 + SrtCol), order1:=xlAscending, Header:=xlYes
        Else
            Columns(Col).Resize(, Cols).Sort Key1:=Cells(1, Col - 1 + SrtCol), order1:=xlAscending, Header:=xlNo
        End If
    Next Col
           
'Add new key column  to collect unique values
    Cells(1, LC + 1) = "Key"
    If Hdrs = 6 Then
        off = True
        FR = 2
    Else
        FR = 1
    End If

    For Col = 1 To LC Step Cols
        Range(Cells(FR, Col - 1 + SrtCol), Cells(Rows.Count, Col - 1 + SrtCol)).SpecialCells(xlConstants).Copy _
           Cells(Rows.Count, LC + 1).End(xlUp).Offset(1)
    Next Col

    Columns(LC + 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, LC + 2), Unique:=True
    Columns(LC + 2).Sort Key1:=Cells(2, LC + 2), order1:=xlAscending, Header:=xlYes

'Fill in new table headers if needed
    If Hdrs = 6 Then
        With Range(Cells(1, LC + 3), Cells(1, LC + 2 + LC))
            .Formula = "=INDEX(1:1, COLUMN(A1))"
            .Value = .Value
        End With
    End If
   
'Fill in new table values
    LR = Cells(Rows.Count, LC + 2).End(xlUp).Row
    On Error Resume Next
   
    For Col = 1 To LC Step Cols
        Set vRNG = Columns(Col - 1 + SrtCol).SpecialCells(xlConstants)
        For Each v In vRNG
            Set vFND = Columns(LC + 2).Find(v, LookIn:=xlValues, LookAt:=xlWhole)
            If Not vFND Is Nothing Then
                If v.Row = 1 Then
                    If Not off Then v.Resize(, Cols).Copy vFND.Offset(, Col)
                Else
                    v.Offset(, 1 - SrtCol).Resize(, Cols).Copy vFND.Offset(, Col)
                End If
            End If
        Next v
    Next Col

'Cleanup/Erase old values
    Range("A1", Cells(1, LC + 2)).EntireColumn.Delete xlShiftToLeft
    Application.ScreenUpdating = True

End Sub

Option Explicit
Sub AlignCustNbr()
' hiker95, 01/10/2011
' http://www.mrexcel.com/forum/showthread.php?t=520077
'
' The macro was modified from code by:
' Krishnakumar, 12/12/2010
' http://www.ozgrid.com/forum/showthread.php?t=148881
'
Dim ws As Worksheet
Dim LR As Long, a As Long
Dim CustNbr As Range
Application.ScreenUpdating = False
Set ws = Worksheets("qty")
LR = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
ws.Range("C1:D" & LR).Sort Key1:=ws.Range("C1"), Order1:=xlAscending, Header:=xlNo, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A1:B" & LR).Sort Key1:=ws.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Set CustNbr = ws.Range("A1:B" & LR)
a = 2
Do While CustNbr.Cells(a, 1) <> ""
  If CustNbr.Cells(a, 1).Offset(, 4) <> "" Then
    If CustNbr.Cells(a, 1) < CustNbr.Cells(a, 1).Offset(, 4) Then
      CustNbr.Cells(a, 1).Offset(, 4).Resize(, 3).Insert -4121
    ElseIf CustNbr.Cells(a, 1) > CustNbr.Cells(a, 1).Offset(, 4) Then
      CustNbr.Cells(a, 1).Resize(, 3).Insert -4121
      LR = LR + 1
      Set CustNbr = ws.Range("A1:B" & LR)
    End If
  End If
  a = a + 1
Loop
Application.ScreenUpdating = 1
End Sub

I have used the above macros but, thus far, they have not been effective in doing what I need.

https://www.mediafire.com/folder/a6v4g50d8s83mzs,1d1v57jmbfb5em6/shared
You can download the Excel files I have with the above link.

Can anyone give me assistance?

Any help will be greatly appreciated.

Thanks!

 

[JLGWhiz]

My security tells me that the files contain a virus and the download was blocked. Could be unsigned macros is causing the security alert, but I won't chance it because of the world wide virus attack.

 

[wideboydixon]

Give this a try:

Public Sub LineUpColumns()

Dim thisCol As Long
Dim lastRow As Long
Dim thisRow As Long
Dim val1 As String
Dim val2 As String

Application.ScreenUpdating = False

For thisCol = 1 To 3 Step 2
    Columns(thisCol).Resize(, 2).Sort Key1:=Cells(1, thisCol), Order1:=xlAscending, Header:=xlNo
Next thisCol

lastRow = Cells(Rows.Count, 1).End(xlUp).Row
thisRow = 1
Do While thisRow <= lastRow
    val1 = Trim(Cells(thisRow, 1).Value)
    val2 = Trim(Cells(thisRow, 3).Value)
    Select Case StrComp(val1, val2, vbTextCompare)
        Case -1
            Cells(thisRow, 3).Resize(, 2).Insert xlShiftDown
            thisRow = thisRow + 1
        Case 1
            Cells(thisRow, 1).Resize(, 2).Insert xlShiftDown
            lastRow = lastRow + 1
            thisRow = thisRow + 1
        Case 0
            thisRow = thisRow + 1
    End Select
    DoEvents
Loop

Application.ScreenUpdating = True

End Sub

WBD

 

[Beowulf891]

Give this a try:

Public Sub LineUpColumns()

Dim thisCol As Long
Dim lastRow As Long
Dim thisRow As Long
Dim val1 As String
Dim val2 As String

Application.ScreenUpdating = False

For thisCol = 1 To 3 Step 2
    Columns(thisCol).Resize(, 2).Sort Key1:=Cells(1, thisCol), Order1:=xlAscending, Header:=xlNo
Next thisCol

lastRow = Cells(Rows.Count, 1).End(xlUp).Row
thisRow = 1
Do While thisRow <= lastRow
    val1 = Trim(Cells(thisRow, 1).Value)
    val2 = Trim(Cells(thisRow, 3).Value)
    Select Case StrComp(val1, val2, vbTextCompare)
        Case -1
            Cells(thisRow, 3).Resize(, 2).Insert xlShiftDown
            thisRow = thisRow + 1
        Case 1
            Cells(thisRow, 1).Resize(, 2).Insert xlShiftDown
            lastRow = lastRow + 1
            thisRow = thisRow + 1
        Case 0
            thisRow = thisRow + 1
    End Select
    DoEvents
Loop

Application.ScreenUpdating = True

End Sub

WBD

You're the man. That's exactly what I needed it to do!

Thanks a lot!