Excel 2007 宏移动重复项

Posted 2023-02-23

【中文标题】Excel 2007 宏移动重复项

【英文标题】：Excel 2007 Macro move duplicates

【发布时间】：2013-01-13 03:55:56

【问题描述】：

我对 Excel 宏一无所知，所以我真的不知道我在做什么，但任何帮助将不胜感激。

我有一个电子表格，在 A - G 行中有列（无标题）。

A 列包含一个 ID，我要做的是将所有重复的 ID 从列结构剪切到行结构。每个 ID 最多可以有 9 行需要移动。

例如 当前格式：

Row 1 - ID123 / Bob / James / 12345 / 1 / A1 / 120
Row 2 - ID124 / John / Smith / 2351 / 5 / C2 / 121
Row 3 - ID124 / John / Smith / 25562 / 1 / A2 / 162
Row 4 - ID162 / Gary / Barlow / 251767 / 9 / B1 / 167

目标格式：

Row 1 - ID123 / Bob / James / 12345 / 1 / A1 / 120
Row 2 - ID124 / John / Smith / 2351 / 5 / C2 / 121 / 25562 / 1 / A2 / 162
Row 3 - ID162 / Gary / Barlow / 251767 / 9 / B1 / 167

所以我的问题是—— a) 这是可行的吗 b）我将如何去做（我很高兴自己制作解决方案，但由于我是 VBA 初学者，因此指出正确的方向会很方便！）

在应用宏之前数据的外观

数据最终应该是什么样子

【问题讨论】：

@lc。更新了问题！

a) 当然。 b）现在不写一个完整的解决方案我会开始循环遍历行，保存你找到的ID，然后当你找到一个重复的（你已经找到的东西）时，回到那一行，附加新值，然后删除后面的行

穷人的解决方案只是做一个数据透视表，你应该能够以这种方式对数据进行分组并得到一些接近的东西。不确定这是否适合您。

【参考方案1】：

你可以试试这个。它正在使用dictionary 对象。此解决方案假定每一行都以 Row 1 - ID123 / Bob / James 模式开头。

Option Explicit

Sub mergeDuplicates()
Dim d As Object
Dim rng As Range
Dim vArr As Variant
Dim i As Integer, j As Integer

Set rng = Sheets(3).Range("A2:H5")
Set d = CreateObject("Scripting.Dictionary")
vArr = rng.Value

For i = LBound(vArr) To UBound(vArr)
    If Not d.Exists(vArr(i, 2)) Then '-- check for unique ID
        d.Add vArr(i, 2), Trim(Replace(vArr(i, 1), "-", ""))
        For j = 2 To UBound(vArr, 2)
            d.Item(vArr(i, 2)) = d.Item(vArr(i, 2)) + "/" & Trim(Replace(vArr(i, j), "/", ""))
        Next j
    Else
        For j = 5 To UBound(vArr, 2)
            d.Item(vArr(i, 2)) = d.Item(vArr(i, 2)) + "/" & Trim(Replace(vArr(i, j), "/", ""))
        Next j
    End If
Next i

'-- output to sheet
rng.Offset(5).Resize(UBound(d.items) + 1, 1) = Application.Transpose(d.items)

'-- split the text to columns
rng.Offset(5).Resize(UBound(d.items) + 1, 1).TextToColumns Destination:= _
        rng.Offset(5), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
        Tab:=True, Semicolon:=False, Comma:=False, Space:=False, _
        Other:=True, OtherChar:="/"

Set d = Nothing
End Sub

输出：

---

按照 OP 的 cmets 和更新

根据他的真实数据更改for loop的内容。

For i = LBound(vArr) To UBound(vArr)
    If Not d.Exists(vArr(i, 1)) Then '-- check for unique ID
        d.Add vArr(i, 1), Trim(vArr(i, 1)) '-- add RowID as first element in item
        For j = 2 To UBound(vArr, 2)  '-- then append each element(column) to the first element
            d.Item(vArr(i, 1)) = d.Item(vArr(i, 1)) + "/" & Trim(Replace(vArr(i, j), "/", ""))
        Next j
    Else
        For j = 4 To UBound(vArr, 2)  '-- when duplicates found, append from 4th column
            d.Item(vArr(i, 1)) = d.Item(vArr(i, 1)) + "/" & Trim(Replace(vArr(i, j), "/", ""))
        Next j
    End If
Next i

基于 OP 更新样本数据的输出：

【讨论】：

@sam.clements 如果您有兴趣，请尝试一下，然后发表评论。表格，范围在此解决方案中是静态的，因为它是一个演示。您可以根据自己的设置。

您好 BonCodigo，让这个工作有一些问题，但可能是由于我的设置！数据中没有“Row 1 -”“Row 2 -”等或“/”，我只是将其放在问题中以尝试显示我的数据格式！

具体来说 - 我已将范围更改为 Set rng = Sheets(3).Range("A2:G500") 以适应第一行的缺失（并处理更大的range) 并且我在 rng.Offset(5).Resize(UBound(d.items) + 1, 1) = Application.Transpose(d.items)

@sam.clements 你能追加正确的几个样本行吗？ （请不要更改早期的样本数据）。如果您可以显示几个示例行的清晰屏幕截图，那就更好了。

完成 - 没有意识到你可以添加图片，否则我会这样做！