VBA Macro Loop only copies one cell of data instead of many - vba

Question

all
I'm a VBA novice here, and I'm being tasked with developing some macros in my new job. Currently, I am working on a macro that goes though a text file, applies some formatting, isolates required numerical data, copies it, and then outputs the copied information into a new Worksheet.
Here's the code for the formatting, just to make sure I post it:
`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
At this point, I now have column B with an amount of 12 digit numbers that varies from file to file. This next part of the macro is a loop that should now look at this Column B, and begin to inspect the cells of Column B to see if they contain 12 digit numbers, and if they do, begin to copy them as a range. Once all the 12 digit numbers in B are found, it should copy them all, open a new tab, and paste the results:
' 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
For whatever reason, when I go through the macro, all it does is capture the first value in B1 and then put that into the Results sheet. I cannot for the life of me figure out why. Could it be due to the filtering I've applied? If anyone could give me some insight, I'd be all ears. Thanks very much for any help you can offer.

Answer 1

This is a fairly simple code that seems to work. Hopefully it meets your needs:
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

I am not sure to understand, but you can try this:
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

I think the problem may be that formatting the numbers to display 0 decimal places is not the same as truncating them. The Len() function will operate on the actual contents (or true value) of the cell, not the displayed value. So if you do have decimals on those numbers, Len() will return a value greater than 12, as it'll count the decimal place and the decimals.
If that is the issue, you'll need to round to 0 decimal places (or truncate to integer) in order to force the actual cell contents to a length of 12.