VBAmacros循环只复制一个数据单元而不是许多
所有
我在这里是一个VBA新手，我的任务是在我的新工作中开发一些macros。 目前，我正在研究通过文本文件，应用某些格式，隔离所需的数字数据，复制它，然后将复制的信息输出到一个新的工作表的macros。
这里是格式化的代码，只是为了确保我发布：
`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位数字，因文件而异。 这个macros的下一个部分是一个循环，现在应该查看这个B列，并开始检查列B的单元格，看它们是否包含12位数字，如果是，则开始复制它们作为范围。 一旦findB中的所有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
无论出于何种原因，当我浏览macros时，它所做的只是捕获B1中的第一个值，然后将其放入结果表中。 我不能为了我的生活找出原因。 难道是由于我应用的过滤吗？ 如果有人能给我一些见解，我会全神贯注。 非常感谢您提供的任何帮助。
这是一个相当简单的代码，似乎工作。 希望它能满足您的需求：
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
我不知道明白，但你可以试试这个：
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
我认为问题可能是格式化数字显示0小数位不同于截断它们。 Len（）函数将对单元格的实际内容（或真实值）进行操作，而不是显示的值。 所以，如果你有这些数字的小数，Len（）将返回一个大于12的值，因为它会计算小数位和小数。
如果这是问题，你需要四舍五入到小数点后0位（或截断为整数），以强制实际单元格内容的长度为12。