At end of for each, have code contine

I have a worksheet that in column C, it takes the label from column D based on whether there is an L in Column B and pastes it in.  When it hits an S the process looks for the next L and copies the label, looping through all the cells in Column B.  However, when it gets to the last L and pastes the header, since there are no more L to look for it throws an Error 91 rather than going to the next line of code.  I have attached the file with the one worksheet and code in modDataProcessing, which has two procedures.  I originall had a Count loop, but found that I did not need that. Sample.xlsm
Sandra SmithRetiredAsked:
Who is Participating?
 
broro183Commented:
Ahhh, sorry, hopefully this is third time lucky!

In my last message I tried to emphasis the change by using the "Bold button" but this doesn't seem to work inside a block of code.

To correct my previous message, please change
With [b]DataWs[/b]

Open in new window

to
With DataWs

Open in new window



Rob
0
 
Glenn RayExcel VBA DeveloperCommented:
I'm not sure why you used the .Find method, but the following code will accomplish what you described.  I did not remove the error handler.  I changed some of the variable definitions, most notably the varColCell (now an Object).

Lines 20-26 do the actual detection of the "L" value and copying of the related Service Description value.
 
Sub CreateHeaders()
    On Error GoTo ErrorHandler
    'First loops through column B and counts how many Ls there are as these are labels, then pulls from the
    'Service Description column the lable, and copies it into Column C until it hits the next L adn then pulls
    'the next label to copy. This goes down to the bottom until there are no more labels.  However, at the end
    'of the Servce Escription column are usually a few items that simply need to be marked as Miscellaneous
    'as they do not seem to be any part of another group.
    Dim rngRange    As Range
    Dim intRowLastCell As Integer
    Dim strMisAddress As String 'need to find first blank cell that does not have a header
    Dim varColCell  As Object
    Dim intLCount   As Integer
    intRowLastCell = Range("B65536").End(xlUp).Row

    'Debug.Print "Last Cell:" & strLastCell
    '    Columns("B:B").Select
    'intLCount = CountLs()
    strMisAddress = "C" & intRowLastCell

    Range("B1:B" & intRowLastCell).Select
    Set rngRange = Selection
    For Each varColCell In rngRange
        If varColCell.Value = "L" Then
            varColCell.Offset(0, 1).Value = varColCell.Offset(0, 2).Value
        End If
    Next varColCell

    Range(strMisAddress).Select
    MsgBox "Stop"
Exit_ErrorHandler:
    Exit Sub
ErrorHandler:
    If Err.Number = 91 Then
    'Actually, this happens when the code reaches the end of the column and there are no
    'more labels, but there are actually rows that do not have headers.
        MsgBox "Error Number:" & Err.Number & vbCrLf & _
           "Description: " & Err.Description & vbCrLf & _
           "Procedure: CreateHeaders ", vbOKOnly
        Resume Exit_ErrorHandler
    Else
    MsgBox "Error Number:" & Err.Number & vbCrLf & _
           "Description: " & Err.Description & vbCrLf & _
           "Procedure: CreateHeaders ", vbOKOnly
        Resume Exit_ErrorHandler
    End If
End Sub

Open in new window


Hope that works.
0
 
Sandra SmithRetiredAuthor Commented:
Interesting, but if you look at the sample, the paste information must go into each field that is an L as well as a number below it until it this an S and then it starts with the next L label..  Bscially anything not an S until it reaches the next label.  This only pastes in the label information on rows in Column C that have an L in column B, which is not really what I want.  I tested it and that is what is does.
0
Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

 
Sandra SmithRetiredAuthor Commented:
I need to use the find as each group of accounts have a different header and I need to determine where the last L was and the next L is so I can determine the rows that need to have the header pasted in column C.
0
 
chwong67Commented:
Try the modified code below
Sub CreateHeaders()
    On Error GoTo ErrorHandler
    'First loops through column B and counts how many Ls there are as these are labels, then pulls from the
    'Service Description column the lable, and copies it into Column C until it hits the next L adn then pulls
    'the next label to copy. This goes down to the bottom until there are no more labels.  However, at the end
    'of the Servce Escription column are usually a few items that simply need to be marked as Miscellaneous
    'as they do not seem to be any part of another group.
    Dim rngRange    As Range
    Dim intRowLastCell As Integer
    Dim strMisAddress As String 'need to find first blank cell that does not have a header
    Dim varColCell  As Object
    Dim intLCount   As Integer
    Dim cel As Object
    intRowLastCell = Range("B65536").End(xlUp).Row

    'Debug.Print "Last Cell:" & strLastCell
    '    Columns("B:B").Select
    'intLCount = CountLs()
    strMisAddress = "C" & intRowLastCell

    Range("B1:B" & intRowLastCell).Select
    Set rngRange = Selection
    For Each varColCell In rngRange
        If varColCell.Value = "L" Then
            varColCell.Offset(0, 1).Value = varColCell.Offset(0, 2).Value
        ElseIf varColCell.Value = "S" Then
            Set cel = Range("B" & varColCell.Row & ":B" & intRowLastCell).Find("L", LookIn:=xlValues)
            If Not cel Is Nothing Then
                varColCell.Offset(0, 1).Value = cel.Offset(0, 2).Value
            End If
        End If
    Next varColCell

    Range(strMisAddress).Select
    MsgBox "Stop"
Exit_ErrorHandler:
    Exit Sub
ErrorHandler:
    If Err.Number = 91 Then
    'Actually, this happens when the code reaches the end of the column and there are no
    'more labels, but there are actually rows that do not have headers.
        MsgBox "Error Number:" & Err.Number & vbCrLf & _
           "Description: " & Err.Description & vbCrLf & _
           "Procedure: CreateHeaders ", vbOKOnly
        Resume Exit_ErrorHandler
    Else
    MsgBox "Error Number:" & Err.Number & vbCrLf & _
           "Description: " & Err.Description & vbCrLf & _
           "Procedure: CreateHeaders ", vbOKOnly
        Resume Exit_ErrorHandler
    End If
End Sub

Open in new window

0
 
broro183Commented:
Here's another variation which may be faster than the other alternatives because it doesn't loop through "cell by cell" or use ".select". I have made a lot of changes in the code to use a variant array which is a fast (possibly the fastest) way to transfer data from a spreadsheet into VBA memory and then back to a spreadsheet.

Sub CreateHeaders_v2()
'First loops through column B and counts how many Ls there are as these are labels, then pulls from the
'Service Description column the lable, and copies it into Column C until it hits the next L adn then pulls
'the next label to copy. This goes down to the bottom until there are no more labels.  However, at the end
'of the Servce Description column are usually a few items that simply need to be marked as Miscellaneous
'as they do not seem to be any part of another group.

'###change the next line as desired, to state what goes in the last few rows (or remove the relevant loop in the code which uses this constant to leave these rows blank).
Const NoLabelStr As String = "Miscellaneous"
    '"Col" on the end of the following constants means "Column" & these only need to be changed if your layout changes.
    'Note: not all of them are currently used but have been included in case the scope of the macro changes...
Const BankServiceIDCodeCol As Long = 1    'not yet used
Const SrvTypeCol As Long = 2
Const HeaderCol As Long = 3    'not yet used
Const ServiceDescCol As Long = 4
Const TrafficeCol As Long = 5    'not yet used
'### once you have checked the output you can change the next line from "... = 7" to "... = 4"
Const OutputCol As Long = 7    'identify a column to output the results to, without overwriting the original values.
Const StartStr As String = "L"
Const EndStr As String = "S"
Dim DataWs As Worksheet
Dim LastRow As Long
Dim DataArr As Variant
Dim RowInd As Long    'row index for use as a loop counter
Dim StartInd As Long
Dim EndInd As Long
Dim InnerInd As Long    'inner loop index (used twice) - this could be more descriptively named!

    'populate initial variables esp the "DataArr" which is a variant array of the spreadsheet contents.
    Set DataWs = ThisWorkbook.Worksheets("CurrentVolumes (modified)")
    With DataWs
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        DataArr = .Range("a1", .Cells(LastRow, OutputCol))
    End With

    'loop through the variant array for all existing rows.
    For RowInd = LBound(DataArr) To UBound(DataArr)

        'identify the next start marker
        Do Until (Trim$(DataArr(RowInd + StartInd, SrvTypeCol)) = StartStr) Or (RowInd + StartInd = UBound(DataArr))
            StartInd = StartInd + 1
        Loop

        'Check if the last row of data has been reached (without finding a label)
        If RowInd + StartInd = UBound(DataArr) Then
            'populate the Output column of the variant array & then exit the main loop
            For InnerInd = 0 To UBound(DataArr) - StartInd - RowInd + 1
                DataArr(RowInd + InnerInd, OutputCol) = NoLabelStr
            Next InnerInd
            Exit For
        End If

        'identify the next end marker
        Do Until (Trim$(DataArr(RowInd + StartInd + EndInd, SrvTypeCol)) = EndStr) Or (RowInd + StartInd + EndInd = UBound(DataArr))
            EndInd = EndInd + 1
        Loop

        'populate the Output column of the variant array
        For InnerInd = 0 To EndInd
            'NOTE: if you want to leave the row with "S" blank, you can use the next commented out line instead of the above one...
            'For InnerInd = 0 To EndInd - 1
            DataArr(RowInd + StartInd + InnerInd, OutputCol) = Trim$(DataArr(RowInd + StartInd, ServiceDescCol))
        Next InnerInd

        'Modifying a loop counter within a loop can be (is always?!) considered BAD practice but it seems easy, safe(?) and I can think of another easy way in this case...
        RowInd = RowInd + StartInd + EndInd
        'reset the counters for the next iteration of the main loop
        StartInd = 0
        EndInd = 0

    Next RowInd

    'transfer the variant array back to the spreadsheet
    With ThisWorkbook.Worksheets("CurrentVolumes (modified)")
        .Range("a1", .Cells(LastRow, OutputCol)) = DataArr
    End With

    MsgBox "done"
    Set DataWs = Nothing
End Sub

Open in new window



hth
Rob
0
 
broro183Commented:
Ooopps, I missed a small change. The last section of my code should be changed from:

    'transfer the variant array back to the spreadsheet
    With ThisWorkbook.Worksheets("CurrentVolumes (modified)")
        .Range("a1", .Cells(LastRow, OutputCol)) = DataArr
    End With

Open in new window


to

    'transfer the variant array back to the spreadsheet
    With [b]DataWs[/b]
        .Range("a1", .Cells(LastRow, OutputCol)) = DataArr
    End With

Open in new window


hth
Rob
0
 
Sandra SmithRetiredAuthor Commented:
Both good suggestions, I will test them and get back.  Rob , I like your idea, but may take a bit for me to analyze and understand what your code is doing.
0
 
Sandra SmithRetiredAuthor Commented:
Ok, this is a little complicated for me and will have to analyse, but actually it worked out better in that I don't have to separately worry about deleteing the L and S rows.  The other suggestion only copied the row header to the next two rows, not all the rows that needed it, so am going with broro183 revised and corrected code.  Thank you both very much.

Sandra
0
 
Sandra SmithRetiredAuthor Commented:
Actually, let me correct my comment, chwong67, your version placed the row header in teh rows that were marked with an L or an S, not the decription rows for each account.  I did not want the row header there as these L and S rows will be deleted.
0
 
broro183Commented:
hi Sandra,

I'm pleased I could help :-)

If you want to delete the L & S rows as part of the same code, you could make one more change to the last section of code and replace it with this one:

    'transfer the variant array back to the spreadsheet & delete the "L" & "S" rows
'(note there is no error handling included for situations where there are no "L" or "S" rows!)

    With DataWs
        With .Range("a1", .Cells(LastRow, OutputCol))
            .Cells = DataArr
            .AutoFilter Field:=2, Criteria1:="=L", Operator:=xlOr, Criteria2:="=S"
            'NOTE: if you have more than 16,000 rows of data, then the next line of code should
            'be changed because of the limitations of "SpecialCells" as discussed on
            'Ron DeBruin's page: www.rondebruin.nl/specialcells.htm
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
        .AutoFilterMode = False
    End With

    MsgBox "done"
    Set DataWs = Nothing
End Sub

Open in new window


hth
Rob
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.