Yinelenen sütunu aynı anda hizalayın ve sonraki sütun

Question

'daki değerleri koruyun Verilerim birçok sütuna yayılır. Bu durumda, A Sütunu ve Sütun B, özdeş adı (çiftler) içerirken, Sütun C - Q, sütun B ile ilgili değerlerdir. Sonraki değerleri korurken, B sütununu Sütun A ile hizalamak istiyorum.

NOT: Sorum çok benzer bu bir etmektir "Align identical data in two columns while preserving values in the 3rd in excel"

Ama benim durumumda ben (C Q) daha sonraki sütunları korumak istiyor. Bu yayında @Jeeped tarafından bir çözüm olarak verilen kodla oynadım ancak başarısız oldu. "Aralığa (: Ben aralığını değiştirmek için bir girişim ("C B1" & lr) yaptık Sub aaMacro1() Dim i As Long, j As Long, lr As Long, vVALs As Variant With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row vVALs = Range("B1:C" & lr) Range("B1:C" & lr).ClearContents For i = 1 To lr For j = 1 To UBound(vVALs, 1) If vVALs(j, 1) = .Cells(i, 1).Value Then .Cells(i, 2).Resize(1, 2) = Application.Index(vVALs, j) Exit For End If Next j Next i End With End Sub

:

Ben

kod aşağıdaki denedi, bu bağlamda herhangi bir yardım alabilir miyim B1: Q "& lr), ama işe yaramadı. Bundan sonra değiştirdim. Yeniden boyutlandırma (1,2) ile .Resize (1,3), ve sonradan iki satır kopyaladı, ancak .Resize (1,4) ile bir kod ekledim, çalışmadı.

Bu düzenlenmiş gönderi, sorumu yanıtlamaya yardımcı olur.

iyi ile orijinal bağlantı kod dayanarak

Answer 1

, herhangi bir sayıda sütun ile çalışması gerekir ...

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 

Test girişi ...

Bu çıktıyı sağlar ...

Answer 2

bu

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