如果单元格以某个 4 个字符开头，则移动到新工作表

Question

对于专家来说，这可能是一个简单的问题，非常抱歉。我是 VBA 新手，花了大约 3 个小时试图通过谷歌搜索来解决这个问题。退出 excel 时，我正在接近并以某种方式丢失了我的代码。

所以我有一个电子表格，它的行数会有所不同。这是一份报告，显示网络中所有计算机正在使用的某个软件的版本。今天的报告有 30,000 行。

有 3 列。 A = 计算机名称。 B = 软件名称。 C = 软件版本。

计算机名称由3个字母、一个破折号和一个名称组成，组成一个单词。

我希望宏查看 A 列的所有行，并移动以例如 ABC-、DEF- 和 XYZ- 开头的 A 列的所有行，但不复制 MNO-。

我希望它将每个分支的计算机复制到自己的新工作表中，这样所有以 ABC- 开头的计算机都会转到名为 ABC（无破折号）的工作表，依此类推。

正如我所说，我丢失了我工作过的代码，所以这就是我目前所拥有的，它是一个简单的删除代码，我一直在努力将其转换为移动代码。

Sub MoveToNewSheet()
Dim i As Long
With ActiveSheet
     For i = .Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
          If Left(.Cells(i, "A").Value, 4) = "DUB-" Then .Rows(i).Delete
     Next
End With

End Sub

Answer 1

我建议使用Range.AutoFilter 方法。

如果包含所有数据的工作表名为 Raw，请尝试以下操作：

Option Explicit
Sub splitData()
    Dim wsSrc As Worksheet, WS As Worksheet, WB As Workbook
    Dim rSrc As Range, rDest As Range
    Dim vSrc As Variant
    Dim cCol As Collection
    Dim I As Long, V As Variant
    Dim sPrefix As String

'set source worksheet and range
Set WB = ThisWorkbook
Set wsSrc = WB.Worksheets("Raw")

'many ways to set the range
'may want to check that there is data on this worksheet
If WorksheetFunction.CountA(wsSrc.Cells) > 0 Then
    Set rSrc = wsSrc.Cells(1, 1).CurrentRegion
Else
    MsgBox "No data on Raw worksheet"
    Exit Sub
End If

'get unique list of computer prefixes
Set cCol = New Collection
vSrc = rSrc.Columns(1) 'faster to loop through arrays

For I = 2 To UBound(vSrc, 1) 'skip the header column
    sPrefix = Split(vSrc(I, 1), "-")(0)

    On Error Resume Next 'collection will error when try to store duplicate key
        cCol.Add Item:=sPrefix, Key:=sPrefix
    On Error GoTo 0
Next I
Application.ScreenUpdating = False

'create new worksheets if needed
'copy relevant data to the new sheet
For Each V In cCol
    Set WS = Nothing
    On Error Resume Next
        Set WS = WB.Worksheets(V)
    On Error GoTo 0

    If WS Is Nothing Then
        Set WS = WB.Worksheets.Add(after:=WB.Worksheets(WB.Worksheets.Count))
        WS.Name = V
    End If

    rSrc.Worksheet.AutoFilterMode = False
    With rSrc
        .AutoFilter field:=1, Criteria1:=V & "-*", Operator:=xlAnd
        .SpecialCells(xlCellTypeVisible).Copy Destination:=WB.Worksheets(V).Cells(1, 1)
        .Worksheet.AutoFilterMode = False
    End With
Next V

End Sub

• 使用 VBA 数组提高速度，遍历所有计算机名称并获取唯一计算机前缀的集合
  • 循环遍历集合，使用计算机前缀
  • 确定目标工作表
    • 如果没有工作表，请创建工作表
  • 为“以”计算机前缀加连字符“开头”设置自动过滤器
  • 将表格中的可见单元格复制到新工作表中
  • 冲洗并重复

为了确保一切正常，我没有从原始数据中删除任何内容，但是，如果需要，您可以轻松地将其添加到代码中。