Как выровнять значения столбцов с их совпадающими значениями в другом столбце?

Question

У меня есть несколько столбцов данных, которые мне нужно выровнять по основному столбцу.

Ниже приведен пример того, чего я надеюсь достичь, но с таблицей, содержащей более крупные строки и больше строк. Данные в каждой строке уникальны, появляются только один раз. Поэтому я просто стремлюсь выровнять эти уникальные значения в столбцах B, C и D со значением A, которое содержит полный список возможных строк. Кроме того, значения в каждом столбце сортируются, поэтому имеет место уменьшение ячеек до тех пор, пока они не выровняются со столбцом A, что я и делал вручную, но хочу автоматизировать:

У меня ограниченный опыт работы с Excel, но все исследования привели меня к использованию этого кода в модуле. К сожалению, когда он запускается, он мало что для меня делает. Со второй попытки, в меру своих способностей, я пытался настроить код так, чтобы он соответствовал диапазону значений в моем листе, но я не могу заставить его работать. Поэтому я надеюсь, что если более опытные участники сообщат мне, действительно ли мне нужно, чтобы код соответствовал моим данным или он просто работал? Спасибо за любую помощь, которую вы можете оказать или просто нашли время, чтобы прочитать!

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("Sheet1")
LR = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
    ws.Range("E3:G" & LR).Sort Key1:=ws.Range("E3"), Order1:=xlAscending, Header:=xlNo, _
   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A3:C" & LR).Sort Key1:=ws.Range("A3"), Order1:=xlAscending, Header:=xlNo, _
   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    Set CustNbr = ws.Range("A2:C" & 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("A3:C" & LR)
    End If
   End If
  a = a + 1
Loop
Application.ScreenUpdating = 1
End Sub!

Answer 1

Я не очень хорош в VBA, но этот код может сделать это:

Option Explicit

Public Sub AlignCustNbr()
    Dim ws As Worksheet
    Dim i As Long

    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    For i = 2 To ws.Columns.Count
        If (Trim(ws.Cells(1, i).Value & "") = "") Then
            Exit For
        End If
        '
        Call Align2Columns(ws, 1, i)
    Next i
End Sub

Private Sub Align2Columns(ws As Worksheet, mainCol As Long, dataCol As Long)
    Dim colData() As String
    Dim strTemp As String, strTemp2 As String
    Dim i As Long, j As Long
    Dim lastDataRow As Integer

    ReDim colData(1 To ws.Rows.Count)
    lastDataRow = 1
    '
    'Findeing aligned datas to colData()
    For i = 1 To ws.Rows.Count
        strTemp = Trim(ws.Cells(i, dataCol).Value & "")
        If (strTemp = "") Then
            Exit For
        End If
        '
        For j = 1 To ws.Rows.Count
            strTemp2 = Trim(ws.Cells(j, mainCol).Value & "")
            If (strTemp2 = "") Then
                lastDataRow = lastDataRow + 1
                colData(j + lastDataRow) = strTemp2
                Exit For

            ' to avoid cese sensetive use commented line
            'ElseIf (UCase(strTemp) = UCase(strTemp2)) Then
            ElseIf (strTemp = strTemp2) Then
                colData(j) = strTemp2
                Exit For

            End If
        Next j
    Next i
    '
    'Update dataCol
    i = 0
    Do
        i = i + 1
        ws.Cells(i, dataCol).Value = colData(i)
        If (Trim(ws.Cells(i, mainCol).Value & "") = "") Then
            lastDataRow = lastDataRow - 1
        End If
    Loop While lastDataRow > 0
End Sub