VBA 宏循环只复制一个数据单元而不是多个

Question

全部

我是这里的 VBA 新手，我的任务是在我的新工作中开发一些宏。目前，我正在研究一个通过文本文件的宏，应用一些格式，隔离所需的数字数据，复制它，然后将复制的信息输出到新的工作表中。

这是格式化的代码，只是为了确保我发布它：

`Perform Text-To-Columns on Column A. Delimited by the character "#"
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="#", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

`Perform Text-To-Columns on Column B. Delimited by the character ")"
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :=")", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

`Format Column B for Numbers to have zero decimal places
Selection.NumberFormat = "0"

`Filter Column B for all numbers greater than 500
Selection.AutoFilter
ActiveSheet.Range("$B$1:$B$1720").AutoFilter Field:=1, Criteria1:=">500", _
    Operator:=xlAnd

`Sort Filtered numbers from lowest to highest
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range( _
    "B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
    .SetRange Range("B1").EntireColumn
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

此时，我现在有 B 列，其中包含 12 位数字，这些数字因文件而异。宏的下一部分是一个循环，现在应该查看此 B 列，并开始检查 B 列的单元格以查看它们是否包含 12 位数字，如果包含，则开始将它们复制为一个范围。找到 B 中的所有 12 位数字后，应将它们全部复制，打开一个新选项卡，然后粘贴结果：

' Declare loop variables
    Dim myLastRow As Long
    Dim myRow As Long
    Dim i As Long
    Dim myValue As String
    Dim myStartRow As Long
    Dim myEndRow As Long

'   Find last row with data in column B
    myLastRow = Cells(Rows.Count, "B").End(xlUp).Row

'   Loop through all data in column B until you find a 12 order number Number
    For myRow = 1 To myLastRow
'       If 12 digit entry is found, capture the row number,
'       then go down until you find the first entry not 12 digits long
        If (Len(Cells(myRow, "B")) = 12) And (IsNumeric(Cells(myRow, "B"))) Then
            myStartRow = myRow
            i = 1
            Do
                If Len(Cells(myRow + i, "B")) <> 12 Then
'               If found, capture row number of the last 13 digit cell
                    myEndRow = myRow + i - 1
'                   Copy the selected data
                    Range(Cells(myStartRow, "B"), Cells(myEndRow, "B")).Copy
'                   Add "Results" as a new sheet for the copied Card Numbers to be pasted into
                    Sheets.Add.Name = "Results"
                    Sheets("Results").Activate
'                   Paste clipboard to "Results" and format the results for viewing
                    Range("A1").Select
                    ActiveSheet.Paste
                    Columns("A:A").EntireColumn.AutoFit
                    Application.CutCopyMode = False
                    Exit Do
                Else
'               Otherwise, move row counter down one and continue
                    i = i + 1
                End If
            Loop
            Exit For
        End If
    Next myRow

无论出于何种原因，当我浏览宏时，它所做的只是捕获 B1 中的第一个值，然后将其放入结果表中。我终其一生都无法弄清楚为什么。可能是由于我应用了过滤吗？如果有人能给我一些见解，我会全神贯注。非常感谢您提供的任何帮助。

Answer 1

这是一个相当简单的代码，似乎可以工作。希望它能满足您的需求：

Sub test1()

Dim ws As Worksheet
Dim res As Worksheet
Dim val As String

Set ws = ActiveSheet
Sheets.Add
Set res = ActiveSheet
res.Name = "Results"
ws.Select
Range("B1").Select

While ActiveCell.Value <> ""

If Len(ActiveCell.Value) = 12 Then

val = ActiveCell.Value
res.Select
ActiveCell.Value = val
ActiveCell.Offset(1, 0).Select
ws.Select
ActiveCell.Offset(1, 0).Select

Else

ActiveCell.Offset(1, 0).Select

End If

Wend

res.Select
Columns("A:A").EntireColumn.AutoFit
Range("A1").Select

End Sub

Answer 2

我不太清楚，但你可以试试这个：

Option Explicit

Sub CopyNumber()

Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1") 'Change the name of the sheet
Dim Result As Worksheet

Dim ws1Lastrow As Long, LastrowResult As Long
Dim i As Long, Rng As Range
Dim TestLenght, Arr

Sheets.Add.Name = "Results" ' Add your new sheet
Set Result = ThisWorkbook.Sheets("Results")

With ws1

    ws1Lastrow = .Range("B" & Rows.Count).End(xlUp).Row 'Find the lastrow in the Source Data Sheet
    Set Rng = .Range("B1:B" & ws1Lastrow) 'Set your range to put into your Array
    Arr = Rng.Value

For i = LBound(Arr) To UBound(Arr)

    TestLenght = Arr(i, 1)

            If Len(Trim(TestLenght)) = 12 And IsNumeric(TestLenght) Then ' Test your data

                    LastrowResult = Result.Range("A" & Rows.Count).End(xlUp).Row + 1
                    Result.Cells(LastrowResult, "A") = TestLenght ' Past your data from your array to the Result Sheet

            End If

Next ' next data of the Array

End With

End Sub

Answer 3

我认为问题可能在于将数字格式化为显示 0 位小数与截断它们不同。 Len() 函数将对单元格的实际内容（或真值）进行操作，而不是显示的值。因此，如果这些数字确实有小数，Len() 将返回一个大于 12 的值，因为它会计算小数位和小数。

如果这是问题所在，您需要四舍五入到小数点后 0 位（或截断为整数），以强制实际单元格内容的长度为 12。