Как я могу оценить число в столбце, чтобы определить, копировать ли данные на другой лист или нет

Question

У меня есть ряд данных, которые зависят от одного столбца, столбца «Entity».Эта сущность представляет собой просто число от 1 до 3000, которое идентифицирует единицы оборудования.Я хочу оценить это число и сделать так, чтобы VBA скопировал его на другой лист на основе номера объекта.Вот что у меня есть:

Sub SplitWOByLines()
    Dim LastRow
    Dim FirstRow
    Dim Cnt
    Set DestSheet = Worksheets("4-3-2011")
    FirstRow = 6
    LastRow = ActiveSheet.UsedRange.Rows.Count
    For Cnt = FirstRow To 10
        If ActiveSheet.Cells(Cnt, 7) = 4034 Then
            ActiveSheet.Cells(Cnt, 3).Select
            Selection.Copy
            ActiveSheet.Paste Destination:=Worksheets("4-3-2011").Cells(Cnt - 3, 2)
            ActiveSheet.Cells(Cnt, 5).Select
            Selection.Copy
            ActiveSheet.Paste Destination:=Worksheets("4-3-2011").Cells(Cnt - 3, 3)
            ActiveSheet.Cells(Cnt, 8).Select
            Selection.Copy
            ActiveSheet.Paste Destination:=Worksheets("4-3-2011").Cells(Cnt - 3, 4)
            ActiveSheet.Cells(Cnt, 10).Select
            Selection.Copy
            ActiveSheet.Paste Destination:=Worksheets("4-3-2011").Cells(Cnt - 3, 5)
            ActiveSheet.Cells(Cnt, 6).Select
            Selection.Copy
            ActiveSheet.Paste Destination:=Worksheets("4-3-2011").Cells(Cnt - 3, 6)
            ActiveSheet.Cells(Cnt, 9).Select
            Selection.Copy
            ActiveSheet.Paste Destination:=Worksheets("4-3-2011").Cells(Cnt - 3, 7)
        End If
    Next Cnt
End Sub

«4034» - это примерный номер объекта для данных.У меня есть только цикл, проходящий строки 6-10 для целей тестирования.

Как заставить VBA пройти через все строки и скопировать только те, которые имеют определенные идентификаторы?Например, если эта ячейка эквивалентна 4034, 169, 4015, 2525, 195, 318, 1537 и т. Д. ... может быть 50 для каждого запроса.В настоящее время я могу заставить его найти только одну сущность за раз.

Я не знаю ни одного оператора «Если равен x или y, или z или ...», чтобы сделать это легко.Я думал о Select / Case, но это будет много повторяющегося кода для копирования и вставки, не так ли?

Любая помощь приветствуется.

Answer 1

Ваша основная идея выглядит хорошо для меня. Просто добавьте еще один цикл, чтобы просмотреть интересующие вас номера сущностей, например,

Dim myEntities
myEntities = Array(4013, 4503, 57, 1111) ' or whatever

For Cnt = FirstRow To 10
    currentEntity = ActiveSheet.Cells(Cnt, 7)
    For iEntity = LBound(myEntities) To UBound(myEntities)
        If currentEntity  = myEntities(iEntity) Then
            '...
        End If
    Next iEntity
Next Cnt

Пара важных моментов:

Всегда Избегайте копирования / вставки , если это вообще возможно! Скопируйте и вставьте использовать буфер обмена. Другие программы могут выполнять чтение / запись в буфер обмена во время работы вашего кода, что приведет к непредсказуемым непредсказуемым результатам. Если вы действительно должны использовать метод .Copy, используйте его так:

ActiveSheet.Cells(Cnt, 3).Copy _
    Destination:=Worksheets("4-3-2011").Cells(Cnt - 3, 2)

Избегайте зацикливания в ячейках , поскольку это супер медленный . Вместо этого загрузите блок ячеек сразу в массив Variant, выполните ваши манипуляции в VBA (например, измените порядок значений, как вы это делаете), а затем запишите все обратно на лист. Это ускорит ваш код на порядок +.

Dim varSource As Variant
Dim varDestination As Variant
' ...
varSource = rngMySourceRange
' Manipulate data here. Place processed data in varDestination.
rngMyDestinationRange = varDestination

Кроме того, весь жаргон .Select / Selection. является ненужным и неэффективным. Вот как Excel генерирует макросы автоматически, но мыслящий человек не должен воспроизводить это. Вместо чего-то вроде:

        ActiveSheet.Cells(Cnt, 3).Select
        Selection.Copy

всегда пишите более лаконичную версию, т.е.

        ActiveSheet.Cells(Cnt, 3).Copy

Answer 2

ТАК, в зависимости от количества данных, которые вы анализируете, это может быть длительный кусок кода!

Звучит так, как будто вы проверяете много строк, поэтому вы можете проверитьMS запрос вместо.Тем не менее, здесь приведен пример кода, который я взломал вместе.Возможно, вам придется возиться с этим, поскольку я не знаю, откуда вы получаете значения критериев:

'I am passing a collection of values to search for. If the range of values you are searching
'for exists as a RANGE of values within a spreadsheet, you can change the collection param
'to a range object instead.
Public Sub SplitWOBByLines(ByVal DestSheet As Worksheet, ByVal FindItems As Collection)
    Dim SourceSheet As Worksheet
    Dim ColumnRange As Range
    Dim RowRange As Range
    Dim SearchRange As Range
    Dim EntityCell As Range

    'You COULD pass this in as a param as well
    Set SourceSheet = ActiveSheet

    'Find the columns used in the Source worksheet:
    Set ColumnRange = SourceSheet.UsedRange.Columns

    'Find the Rows used in the source worksheet:
    Set RowRange = SourceSheet.UsedRange.Rows

    'The Search area is the intersection of the two:
    Set SearchRange = Intersect(ColumnRange, RowRange)

    'An iteration variable for For . . .Next loop:
    Dim CurrentItem As Variant

    'An iteration variable for the inner For . . .Next loop:
    Dim CurrentRow As Range

    'A placeholder variable for the output row index:
    Dim DestinationRowIndex As Integer

    'Find the area of the destination sheet already used (If sheet is empty, this will be 1):
    DestinationRowIndex = DestSheet.UsedRange.Rows.Count

    If DestinationRowIndex > 1 Then
        'Data already exists. Start at the row AFTER the last used row:
        DestinationRowIndex = DestinationRowIndex + 1
    End If

    'Outer loop iterates through the items you are Searching for:
    For Each CurrentItem In FindItems

        'Inner loop iterates through the rows in the Source sheet
        'which contain data:
        For Each CurrentRow In SearchRange.Rows
            If CurrentRow.Cells(, 7) = CurrentItem Then
                CurrentRow.Copy
                SourceSheet.Paste DestSheet.Cells(DestinationRowIndex, 1)
                DestinationRowIndex = DestinationRowIndex + 1
           End If
        Next
    Next

End Sub

'I used the WorkSheet_SelectionChange Event to trigger a test, using some random
'data I placed in the source sheet, and some arbitrary values added to the collection:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim DestSheet As Worksheet
    Set DestSheet = Worksheets("4-3-2011")
    Dim colFindItems As Collection

    Set colFindItems = New Collection
    colFindItems.Add 20
    colFindItems.Add 40

    Call Me.SplitWOBByLines(DestSheet, colFindItems)

End Sub

Answer 3

Не совсем уверен, что я следую, но посмотрите, дает ли это вам идею:

Шаг 1, создайте коллекцию, содержащую местоположение каждого действительного объекта, со значением объекта в качестве ключа:

Dim ValidEntities As New Collection
' item #4043 can be found at A5
Call ValidEntities.Add(Range("A5"), "4043")  ' note: keys should be strings
' item #4015 can be found at A6
Call ValidEntities.Add(Range("A6"), "4015")
' etc.

Шаг 2: переписать ваш цикл, чтобы проверить членство в коллекции.

' loop over a list of values to check (hardcoded here to check just one)
dim EntityNo as long
dim rgEntity as range

set rgEntity = nothing
on error resume next: set rgEntity = ValidEntities(cstr(EntityNo)): on error goto 0
if rgEntity is nothing
    ' not found - handle error
else
    ' found - rgEntity now points to the range corresp to EntityNo
endif