excel - Excel VBA - セルの移動

Question

単純なセルの移動のように見えますが、10,000 行を超える場合、手動で行うには面倒です。これを行うには、より迅速な方法が必要です。

入力

A列 B列
1×
2年
1Z

出力

A列 B列 C列
1 XZ
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 から値を取得し、既存のキーの隣にある次の利用可能な列に入れます。次に、空の行を削除するため、左側に 1 つの一意のキー セットがあり、対応するすべての値が右側にあります。

---

編集 - このコードは、列 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

サブ終了