时间戳

首页 > 解决方案 > 如果单元格以某个 4 个字符开头，则移动到新工作表

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

问题描述

对于专家来说，这可能是一个简单的问题，所以很抱歉。我是 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

标签： excelvba

解决方案

我建议使用该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 数组提高速度，遍历所有计算机名称并获取唯一计算机前缀的集合
    • 循环遍历集合，使用计算机前缀
    • 确定目标工作表
      • 如果不存在则创建工作表
    • 为“开始于”计算机前缀加上连字符设置自动过滤器
    • 将表格中的可见单元格复制到新工作表
    • 冲洗并重复

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

推荐阅读