In excel ordering Column C according Column A, the data of column C e D are to move together.

Ex: First row will be

I've tried excel functions like:

PROCV, VLOOKUP and the sort and filter button in excel with no luck.

CodePudding user response：

Note:

1. All rows must be uniquely identified by the name in column a
2. You need to reference Microsoft Scripting Runtime

... anyway

Sub sheesh()

    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim i As Integer
    For i = 1 To lastRow
        dict.Add CStr(ws.Cells(i, 3).Value), CInt(ws.Cells(i, 4).Value)
    Next i
    
    For Each k In dict.Keys
        Debug.Print k
    Next
    
    For i = 1 To lastRow
        If dict.Exists(ws.Cells(i, 1).Value) Then
            ws.Cells(i, 3).Value = ws.Cells(i, 1).Value
            ws.Cells(i, 4).Value = dict(ws.Cells(i, 1).Value)
        End If
    Next i
    
End Sub

CodePudding user response：

Align Data

Option Explicit

Sub AlignData()
    
    Const fRow As Long = 1
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim Key As Variant
    Dim r As Long
    
    ' Left two columns to left dictionary.
    
    Dim llRow As Long: llRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim lCount As Long: lCount = llRow - fRow   1
    Dim lrg As Range: Set lrg = ws.Cells(fRow, "A").Resize(lCount, 2)
    Dim lData As Variant: lData = lrg.Value
    Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
    lDict.CompareMode = vbTextCompare
    
    For r = 1 To lCount
        Key = lData(r, 1)
        If Not IsError(Key) Then ' exclude error values
            If Len(Key) > 0 Then ' exclude blanks
                lDict(lData(r, 1)) = lDict(lData(r, 1))   lData(r, 2) ' Sum
            End If
        End If
    Next r
    Erase lData
    lCount = lDict.Count
    
    ' Right two columns to right dictionary.
    
    Dim rlRow As Long: rlRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    Dim rCount As Long: rCount = rlRow - fRow   1
    Dim rrg As Range: Set rrg = ws.Cells(fRow, "C").Resize(rCount, 2)
    Dim rData As Variant: rData = rrg.Value
    Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
    rDict.CompareMode = vbTextCompare
    
    For r = 1 To rCount
        Key = rData(r, 1)
        If Not IsError(Key) Then ' exclude error values
            If Len(Key) > 0 Then ' exclude blanks
                rDict(rData(r, 1)) = rDict(rData(r, 1))   rData(r, 2) ' Sum
            End If
        End If
    Next r
    Erase rData
    rCount = rDict.Count
    
    ' Write to destination arrays.
    
    ReDim lData(1 To lCount, 1 To 2) ' exact size
    ReDim rData(1 To lCount   rCount, 1 To 2) ' oversized
    r = 0
    
    For Each Key In lDict.Keys
        r = r   1
        lData(r, 1) = Key: lData(r, 2) = lDict(Key)
        If rDict.Exists(Key) Then
            rData(r, 1) = Key: rData(r, 2) = rDict(Key)
            rDict.Remove Key
        End If
    Next Key
        
    If rDict.Count > 0 Then
        For Each Key In rDict.Keys
            r = r   1
            rData(r, 1) = Key: rData(r, 2) = rDict(Key)
        Next Key
    End If
    
    ' Overwrite ranges.
    
    With lrg
        .Resize(lDict.Count).Value = lData
        .Resize(ws.Rows.Count - .Row - lCount   1).Offset(lCount).ClearContents
    End With
    With rrg
        .Resize(r).Value = rData
        .Resize(ws.Rows.Count - .Row - r   1).Offset(r).ClearContents
    End With
    
    MsgBox "Data aligned.", vbInformation
    
End Sub