Если ячейка начинается с определенного 4 символа, переходите на новый лист

Question

Это, наверное, простой вопрос для экспертов, поэтому извиняюсь. Я новичок в VBA и провел около 3 часов, пытаясь выяснить это с помощью поиска Google. Я приближался и каким-то образом потерял свой код при выходе из Excel.

Так что у меня есть электронная таблица, которая будет варьироваться в строках. Это отчет, который показывает, какую версию определенного программного обеспечения используют все компьютеры в сети. Сегодняшний отчет содержит 30 000 строк.

Есть 3 столбца. A = имя компьютера. B = название программного обеспечения. C = версия программного обеспечения.

Имя компьютера состоит из 3 букв, да sh и имени, составляющего одно слово.

Я хочу, чтобы макрос просматривал весь ряд строк столбца A и переместите все строки столбца A, который начинается, например, с AB C - и DEF- и XYZ-, но не для копирования MNO -.

Я хотел бы, если бы он скопировал компьютеры для каждой ветви на свой новый лист, так что все компьютеры, начинающиеся с AB C - go на лист, называемый AB C (без da sh) и т. д.

Как я сказал, что потерял код, над которым работал, так что это все, что у меня есть, это простой файл удаления, который я изо всех сил пытался преобразовать в ход.

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 массив для скорости, l oop через все имена компьютеров и получить набор уникальных компьютерных префиксов
  • L oop через коллекцию, используя префикс компьютера к
  • Определить конечный лист
    • создать лист, если его там нет
  • Установить автофильтр для «запускается с» префикса компьютера плюс дефис
  • Копировать видимые ячейки в таблице к новому рабочему листу
  • Сполосните и повторите

Я не удалил ничего из необработанных данных, чтобы убедиться, что все работает , но, если вам нужно, вы можете легко добавить это к коду.