Vba 对齐excel中的重复列，同时保留后续列中的值

我的数据分布在许多列中。在这种情况下，列A和列B具有相同的名称（重复），而列C到Q是与列B相关的值。我希望将列B与列A对齐，同时保留后续的值

注意：我的问题非常类似于这个问题“

但在我的例子中，我希望保留更多后续列（从C到Q）。我在那篇文章中使用了@Jeeped给出的代码作为解决方案，但失败了

在这方面我能得到什么帮助吗

我尝试了以下代码：

Sub-aaMacro1（）
尺寸i为长，j为长，lr为长，vVALs为变型
使用ActiveSheet
lr=.Cells（Rows.Count，1）.End（xlUp）.Row
vVALs=范围（“B1:C”和lr）
范围（“B1:C”和lr）。清除内容
对于i=1至lr
对于j=1至UBound（vVALs，1）
如果vVALs（j，1）=.单元格（i，1）.值，则
.单元格（i，2）.调整大小（1，2）=应用程序索引（vVALs，j）
退出
如果结束
下一个j
接下来我
以
末端接头

我曾尝试将范围（“B1:C”和lr）更改为范围（“B1:Q”和lr），但没有成功。 在此之后，我将.Resize（1,2）更改为.Resize（1,3），它复制了随后的两行，但当我插入带有.Resize（1,4）的代码时，它不起作用

希望这篇经过编辑的文章能帮助回答我的问题

---

基于原始链接中的代码，使用best时，应可处理任意数量的列

Option Explicit
Option Base 1
Sub aaMacro1()

    Dim i As Long, j As Long, k As Long
    Dim nRows As Long, nCols As Long
    Dim myRng As Range
    Dim vVALs() As Variant

    With ActiveSheet
        nRows = .Cells(Rows.Count, 1).End(xlUp).Row
        nCols = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set myRng = .Range(.Cells(2, 2), .Cells(nRows, nCols))
    End With
    nRows = nRows - 1
    nCols = nCols - 1

    vVALs = myRng.Value
    myRng.ClearContents
    For i = 1 To nRows
        For j = 1 To nRows
            If vVALs(j, 1) = ActiveSheet.Cells(i + 1, 1).Value Then
                For k = 1 To nCols
                    myRng.Cells(i, k).Value = vVALs(j, k)
                Next k
                Exit For
            End If
        Next j
    Next i
End Sub

测试输入

提供此输出

---

基于原始链接中的代码，可以处理任意数量的列

Option Explicit
Option Base 1
Sub aaMacro1()

    Dim i As Long, j As Long, k As Long
    Dim nRows As Long, nCols As Long
    Dim myRng As Range
    Dim vVALs() As Variant

    With ActiveSheet
        nRows = .Cells(Rows.Count, 1).End(xlUp).Row
        nCols = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set myRng = .Range(.Cells(2, 2), .Cells(nRows, nCols))
    End With
    nRows = nRows - 1
    nCols = nCols - 1

    vVALs = myRng.Value
    myRng.ClearContents
    For i = 1 To nRows
        For j = 1 To nRows
            If vVALs(j, 1) = ActiveSheet.Cells(i + 1, 1).Value Then
                For k = 1 To nCols
                    myRng.Cells(i, k).Value = vVALs(j, k)
                Next k
                Exit For
            End If
        Next j
    Next i
End Sub

测试输入

提供此输出

你可以试试这个

Option Explicit

Sub AlignDupes()

Dim lRow As Long, iRow As Long
Dim mainRng As Range, sortRange As Range

With ActiveSheet
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set mainRng = .Range("A1:A" & lRow)
    Set sortRange = .Range("B1:Q1").Resize(mainRng.Rows.Count)
    .Sort.SortFields.Clear
End With
Application.AddCustomList ListArray:=mainRng

With sortRange
    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

    iRow = 1
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Do While iRow <= lRow
        Do While .Cells(iRow, 1) <> .Cells(iRow, 1).Offset(, -1)
            .Rows(iRow).Insert
            iRow = iRow + 1
            lRow = lRow + 1
        Loop
        iRow = iRow + 1
    Loop
End With

Application.DeleteCustomList Application.CustomListCount

End Sub

选项显式
子副本（）
暗如长河，暗如长河
变暗维护组件范围，分拣组件范围
使用ActiveSheet
lRow=.Cells（.Rows.Count，1）.End（xlUp）.Row
设置mairng=.Range（“A1:A”和lRow）
设置sortRange=.Range（“B1:Q1”）.Resize（mairng.Rows.Count）
.Sort.SortFields.Clear
以
Application.AddCustomList ListArray:=mainRng
用sortRange
.Sort Key1:=.Cells（1，1），Order1:=xlAscending，Header:=xlNo，OrderCustom:=Application.CustomListCount+1，MatchCase:=False，Orientation:=xlTopToBottom，DataOption1:=xlSortNormal
iRow=1
lRow=.Cells（.Rows.Count，1）.End（xlUp）.Row
你可以试试这个

Option Explicit

Sub AlignDupes()

Dim lRow As Long, iRow As Long
Dim mainRng As Range, sortRange As Range

With ActiveSheet
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set mainRng = .Range("A1:A" & lRow)
    Set sortRange = .Range("B1:Q1").Resize(mainRng.Rows.Count)
    .Sort.SortFields.Clear
End With
Application.AddCustomList ListArray:=mainRng

With sortRange
    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

    iRow = 1
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Do While iRow <= lRow
        Do While .Cells(iRow, 1) <> .Cells(iRow, 1).Offset(, -1)
            .Rows(iRow).Insert
            iRow = iRow + 1
            lRow = lRow + 1
        Loop
        iRow = iRow + 1
    Loop
End With

Application.DeleteCustomList Application.CustomListCount

End Sub

选项显式
子副本（）
暗如长河，暗如长河
变暗维护组件范围，分拣组件范围
使用ActiveSheet
lRow=.Cells（.Rows.Count，1）.End（xlUp）.Row
设置mairng=.Range（“A1:A”和lRow）
设置sortRange=.Range（“B1:Q1”）.Resize（mairng.Rows.Count）
.Sort.SortFields.Clear
以
Application.AddCustomList ListArray:=mainRng
用sortRange
.Sort Key1:=.Cells（1，1），Order1:=xlAscending，Header:=xlNo，OrderCustom:=Application.CustomListCount+1，MatchCase:=False，Orientation:=xlTopToBottom，DataOption1:=xlSortNormal
iRow=1
lRow=.Cells（.Rows.Count，1）.End（xlUp）.Row
我不确定stackoverflow是否是为了帮助那些“不能自己编写或编辑代码”的人而设计的。你至少应该试着发布你尝试过的代码以及出错的地方。我不确定stackoverflow是否是为了帮助那些“不能自己编写或编辑代码”的人。你至少应该试着把你试过的代码和出错的地方贴出来。谢谢你提供的@oldsught脚本为我工作得很好。而且@nhouser我一定会听从你的建议，并且会在我问新问题时发布代码，BestThank You@OldShughous脚本由你提供，非常适合我。和@nhouser我一定会按照你的建议，并将张贴代码，无论我问什么新问题，最好