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