Копирование строк в рабочий лист на основе значения в определенном столбце не распространяется на всю таблицу

Question

Я перебираю значения в столбце B текущего рабочего листа.Если длина значения составляет 8 символов, скопируйте строку ВЕСЬ на другой лист.Это отчасти работает, но я пропускаю около ста строк, которые должны были быть скопированы.

Я полагаю, это связано с форматом значений ячеек в столбце B. Есть некоторые, которые являются просто текстомзаголовки, которые точно не будут соответствовать критериям.Все, что он должен скопировать, все в этом формате (столбец B):

6008571X
60088242
....

Интересующие меня строки содержат 8 символов в столбце B. Проблема в том, что некоторые из них могут быть отформатированы какчисел некоторые в виде текста (или, возможно, предшествует ').

Sub aims()
    Dim i As Long
    'Get the address of the first non blank cell in Row B from the bottom
    MyFirstBlankAddress = Range("B1048576").End(xlUp).Offset(1, 0).Address
    'Extract the number from the address to get the row number
    MyRowNumber = Split(MyFirstBlankAddress, "$")(2)

    For i = 1 To MyRowNumber
        With Range("B" & i)
            If Len(.Value) = 8 Then .EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
        End With
    Next i
End Sub

Я ожидал, что скопировано 410 строк, в то время как только 276 были скопированы.

РЕДАКТИРОВАТЬ: Я читал ваши ответы / предложения и тестирование материала.Я узнал, что проблема заключается в другом.Мой оригинальный код правильно идентифицирует строки, это связано с копированием.

Если я изменю свой код, просто выделив совпадающие строки, он совпадет со всеми правильными строками:

If Len(.Value) = 8 Then .EntireRow.Interior.Color = 5296274

Answer 1

Я уверен, что есть лучший способ сделать копирование / вставку, где ваша проблема, но ниже работает.

Sub aims()
Dim i As Long
Dim vLastRow As Long
Dim s2 As Long

'find last row in sheet, or you could change to find last row in specified column
'Example: Cells = Columns(column number or letter), Cells(1, 1) = Cells(1, column number)
vLastRow = Cells.Find(what:="*", after:=Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row
s2 = 1

Application.ScreenUpdating = False

For i = 1 To vLastRow
    If Trim(Len(CStr(Cells(i, 2)))) = 8 Then
        Rows(i).EntireRow.Copy Destination:=Sheets(2).Range(Cells(s2, 1).Address)
        s2 = s2 + 1
    End If
Next i

Application.ScreenUpdating = True

End Sub

Answer 2

Вы можете попробовать что-то вроде этого.Приведенный ниже код пытается скопировать все сразу, вместо множества копий / вставок.Два теста проверяют, имеет ли усеченное значение длину символа 8 ИЛИ, если усеченное значение имеет длину символа 9, но последний символ является апострофом.Если любой из этих критериев будет выполнен, мы добавим эту ячейку к Union.

Как только код перебрал все строки, он скопирует весь союз за один раз

Option Explicit

Sub shooter()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update
Dim LR As Long, i As Long, Add As Boolean, CopyMe As Range
Dim x As Range

LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row

For Each x In ws.Range("B2:B" & LR)
  Add = False

    If Len(Trim(x)) = 8 Then
        Add = True
    ElseIf Len(Trim(x)) = 9 And Right(Trim(x), 1) = "'" Then
        Add = True
    End If

    If Add Then
        If Not CopyMe Is Nothing Then
            Set CopyMe = Union(CopyMe, x)
        Else
            Set CopyMe = x
        End If
    End If

Next x

If Not CopyMe Is Nothing Then
    CopyMe.EntireRow.Copy Destination:=Sheets(2).Range(“A1”)
End If

End Sub