Question

我正在遍历当前工作表的B列中的值。如果该值的长度为8个字符，则将整个行复制到另一张纸上。可以，但是我缺少大约一百行应该被复制的行。

我想这与B列中单元格值的格式有关。有些仅仅是Text标头，肯定不符合标准。它应该复制的格式都是这种格式（B列）：

6008571X
60088242
....

我感兴趣的行在B列中有8个字符。问题是，其中一些可能会格式化为数字，某些可能会格式化为文本（或者可能以'开头）。

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

您可以尝试类似的方法。下面的代码尝试一次复制所有内容，而不是具有许多复制/粘贴实例。这两个测试正在查看修剪后的值的字符长度为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

Answer 2

我确定有更好的方法来复制/粘贴，这是您遇到的问题，但是以下方法可以工作。

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

根据特定列中的值将行复制到wksheet不适用于我的整个电子表格

2 个答案: