Excel VBA - 移动单元格

Question

看起来像一个简单的单元格移动，但是当有超过 10,000 行时，手动操作太繁琐了。需要一种更快的方法来执行此操作。

输入

A列 B列 1个 2年 1 Z

输出

A 列 B 列 C 列 1 X Z 2年

Answer 1

这就是你所追求的吗？

Sub ShiftCells()

Dim rnAll As Range, rnCell As Range, rnTarget As Range

Set rnAll = Sheet1.Range("A1:A" & Sheet1.UsedRange.Rows.Count)

For Each rnCell In rnAll
    If WorksheetFunction.CountIf(Sheet1.Range(rnCell.Address, rnAll.Cells(1)), rnCell.Value) > 1 Then
        Set rnTarget = rnAll.Find(rnCell.Value, rnAll.Cells(rnAll.Cells.Count), xlValues, xlWhole, xlByRows, xlNext, True, True)
        rnTarget.EntireRow.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Offset(0, 1).Value = rnCell.Offset(0, 1).Value 'Move value to next free column in corresponding index row
        rnCell.Value = ""
    End If
Next

If rnAll.SpecialCells(xlCellTypeBlanks).Count > 0 Then
    rnAll.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If

End Sub

它检查第 1 列中的所有值，如果该“键”已存在于其上方，则从第 2 列中获取值并将其放入现有键旁边的下一个可用列中。然后它会删除空行，因此您最终会在左侧得到一组唯一的键，而右侧的所有对应值。

---

编辑 - 此代码将值从 B 列移动到从 K 开始的列，如果索引不存在则添加：

Sub ShiftCells()

Dim rnAll As Range, rnCell As Range, rnTarget As Range, rnDestination As Range

Set rnAll = Sheet1.Range("A1:A" & Sheet1.UsedRange.Rows.Count)
Set rnDestination = Sheet1.Range("K1:K" & Sheet1.UsedRange.Rows.Count)

For Each rnCell In rnAll
    If WorksheetFunction.CountIf(rnDestination, rnCell.Value) = 0 Then 'Index doesn't exist
        Set rnTarget = rnDestination.Cells(1).Offset(WorksheetFunction.CountA(rnDestination), 0)
            rnTarget.Value = rnCell.Value 'Populate the index if it doesn't exist
            rnTarget.Next.Value = rnCell.Next.Value
    Else 'Index exists
        Set rnTarget = rnDestination.Find(rnCell.Value, rnDestination.Cells(rnAll.Cells.Count), xlValues, xlWhole, xlByRows, xlNext, True, True)
            rnTarget.EntireRow.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Next.Value = rnCell.Next.Value 'Move value to next free column if index exists
    End If
Next

结束子