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

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.