VBA宏 根据条件将单元格移动到下一列的顶部

Question

我有一些电子表格数据将位于多个列中，但列数将根据条目数从 1 到 8 不等。 我有一些条目以以下格式的相同 2 个字符开头： CF 12456 这些"CF 12345"中可能只有 1 个或许多 一旦数据分散到均匀分布的列中，我需要将所有带有"CF 12345"的单元格移动到新列中，该列将是最后一列数据(即，如果有 6 列数据， "CF 12345"列应位于第 6 栏的右侧(。 这段代码完成了所有这些工作，除了它将所有"CF 12345"移动到第一列(是的，我知道它，因为这是代码告诉它要做的(。 这是代码：

Sub DiscrepancyReportMacroStepTwo()
    'Step 4: Find CF cells move to the top of their own column
    Dim rngA As Range
    Dim cell As Range
    Set rngA = Sheets("Sheet1").Range("A2:H500")
    For Each cell In rngA
        If cell.Value Like "*CF*" Then
            cell.Copy cell.Offset(0, 1)
            cell.Clear
        End If
    Next cell
End Sub

Answer 1

迭代所用范围的列，对于找到的每个与模式匹配的单元格，将其值与顶部单元格交换。如果需要保留所有单元格值，则需要跟踪需要交换的当前顶行。

顺便说一下，你的模式似乎是"CF *"，而不是"*CF*"，除非你在问题描述中犯了错误。此代码会将所有CF *单元格移动到顶部，同时保留工作表中存在的所有值。

Sub DiscrepancyReportMacroStepTwo()
  Dim cel As Range, col As Range, curRow As Long, temp
  For Each col In Sheets("Sheet1").UsedRange.Columns
    curRow = 1
    For Each cel In col.Cells
      If cel.Value2 Like "CF *" Then
        ' Swap values of the cell and a cel from top of the column (at curRow)
        temp = col.Cells(curRow).Value2
        col.Cells(curRow).Value2 = cel.Value2
        cel.Value2 = temp
        curRow = curRow + 1
      End If
    Next cel
  Next col
End Sub

编辑

上面的代码将CF *单元格移动到列的顶部。若要将它们添加到新的单独列中，请使用以下命令：

Sub DiscrepancyReportMacroStepTwo()
  Dim lastColumn As Long, lastRow As Long, cel As Range, curRow As Long
  With Sheets("Sheet1")
    lastColumn = .Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious).Column
    lastRow = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).row
    For Each cel In .Range("A2", .Cells(lastRow, lastColumn))
      If cel.Value2 Like "CF *" Then
        curRow = curRow + 1
        .Cells(curRow, lastColumn + 1).Value2 = cel.Value2
        cel.Clear
      End If
    Next cel
  End With
End Sub

Answer 2

您可以使用正则表达式来查找"CF *"值，这将确保您仅根据问题陈述选择以"CF"开头后跟 5 位数字的值。 如果您不知道数字的 #，但知道它将在 2 到 5 位数字之间，则可以将正则表达式模式更改为："^CF [d]{2,5}$"

Option Explicit
Sub Move2LastCol()
  Dim sht As Worksheet
  Set sht = Worksheets("Sheet1")
  Dim regEx As Object
  Set regEx = CreateObject("vbscript.regexp")
  regEx.Pattern = "^CF [d]{5}$"
  Dim r As Integer, c As Integer, lastRow As Integer, lastCol As Integer
  Dim tmp As String
  With sht
    lastCol = .Cells.Find(What:="*", SearchOrder:=xlColumns, _
              SearchDirection:=xlPrevious, LookIn:=xlValues).Column + 1
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For r = 1 To lastRow:
      Dim c1 As Integer: c1 = lastCol
      For c = 1 To .Cells(r, lastCol).End(xlToLeft).Column:
       If regEx.Test(.Cells(r, c)) Then
          tmp = .Cells(r, c).Value2
          .Cells(r, c).Clear
          .Cells(r, c1).Value2 = tmp
          c1 = c1 + 1
          Exit For
       End If
      Next
    Next
  End With
End Sub