Question

我正在尝试编写一个宏，它将从单个列中删除一些重复的ID，以便它只在列中出现一次，并将Item单元格中的数据放入该项的行中。

到目前为止我的excel电子表格的示例： -

 A   B        c
1    ID       Name          Item
2   555      Joe Bloggs     Orange
3   555      Joe Bloggs     Blue
4   454      Gale Force     Orange
5   333      Justin Store   Green
6   333      Justin Store   Purple
7   333      Justin Store   Blue
8   525      Graham Wood    Pruple

它继续像randonly那样ID的一些出现超过4次但每个都有不同的项目。我想要的是它看起来像这样： -

A    B         C            D         E          F         G
1   ID       Name          Item      Item       Item       Item
2   555      Joe Bloggs    Orange    Blue
3   454      Gale Force    Orange  
4   333      Justin Store  Green    Purple      Blue
5   525      Graham Wood   Pruple

是否可以编写一个可以执行此操作的宏？

示例中的名称等的应用，我实际上不能附加文档的副本或输入相同的数据，所以我已经提取了信息，但原理是相同的。

由于

Answer 1

尝试以下宏。它适用于您的示例，其中第1行包含标题行，而实际数据从A2开始：

Sub flatten()
    Dim ro As Integer
    Dim oRow As Integer
    Dim rng As Range

    For ro = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
        Set rng = Range(Cells(1, 1), Cells(ro, 1))
        If Application.WorksheetFunction.CountIf(rng, Cells(ro, 1)) > 1 Then
            oRow = rng.Find(Cells(ro, 1), MatchCase:=True).Row
            Cells(oRow, Cells(oRow, 1).End(xlToRight).Column + 1) = Cells(ro, 3)
            Rows(ro).Delete
            ro = ro - 1
        End If
Next
End Sub

Answer 2

此子程序适用于我：

Sub MakeUniqueAndTranspose()
    Application.ScreenUpdating = False
    RowCount = Range("C" & Rows.Count).End(xlUp).Row
    For i = RowCount To 2 Step -1
       With Range("C" & i)
           If .Value <> .Offset(-1).Value Then Rows(i).Insert
       End With
    Next i
    For Each Area In Columns("D").SpecialCells(xlCellTypeConstants).Areas
       Area(1).Offset(, 1).Resize(, Area.Rows.Count).Value = Application.Transpose(Area)
    Next Area
    'delete the created empty columns between every value
    Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    'delete original column which is now obsolete
    Columns("D").Delete
    'remove the duplicates which are now empty
    Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

创建一个宏，该宏将删除重复数据并从单元格移动数据以显示在单行中

2 个答案: