excel - Excel マクロ 検索 テキスト値 切り取りと貼り付け、セルを上に移動

Question

ある会計パッケージから別の会計パッケージに移行するという悪夢のような作業があります。

列 A、B、G に 9340 行あり、新しいシステムにインポートする前に特定の方法で並べ替える必要があります。

前：

後：

必要なことを行うマクロを実行しましたが、選択した範囲に対してのみ実行しました。シート全体でマクロを機能させるにはどうすればよいですか?

Sub Macro1()

  Range("B206").Select
  Selection.Cut
  Range("A207").Select
  ActiveSheet.Paste
  Rows("206:206").Select
  Selection.Delete Shift:=xlUp
  Range("A206").Select
  Selection.Copy
  Range("A206:A216").Select
  ActiveSheet.Paste
  Range("C216").Select
  Application.CutCopyMode = False
  Selection.Cut
  Range("G216").Select
  ActiveSheet.Paste
End Sub

Answer 1

これは、いくつかの点で失敗する可能性があります。あなたのセットアップは、私が再作成する時間よりも複雑です。データのコピーに対してこのコードを実行してください。基本的に、物事を移動してから、列Bに空白があるすべての行を削除します。最初の「Opening」行の上にあるヘッダージャンクを削除する必要があります。

Sub test()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim cell As Excel.Range

Set ws = ActiveSheet
With ws
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For Each cell In .Range("B1:B" & LastRow)
    If Left(cell.Value, Len("Opening")) = "Opening" Then
        cell.Offset(1, -1).Value = cell.Value
        cell.ClearContents
    Else
        cell.Offset(0, -1) = cell.Offset(-1, -1).Value
    End If
    If Left(cell.Value, Len("Closing")) = "Closing" Then
        cell.Offset(0, 6).Value = cell.Offset(0, 1).Value
        cell.Offset(0, 1).ClearContents
    End If
Next cell
    .Range("B" & .Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub