?
Solved

At end of for each, have code contine

Posted on 2011-10-26
11
Medium Priority
?
244 Views
Last Modified: 2012-05-12
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
0
Comment
Question by:ssmith94015
11 Comments
 
LVL 27

Expert Comment

by:Glenn Ray
ID: 37034462
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
 

Author Comment

by:ssmith94015
ID: 37034615
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
 

Author Comment

by:ssmith94015
ID: 37034697
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
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 9

Expert Comment

by:chwong67
ID: 37035038
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
 
LVL 10

Expert Comment

by:broro183
ID: 37035626
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
 
LVL 10

Expert Comment

by:broro183
ID: 37035642
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
 
LVL 10

Accepted Solution

by:
broro183 earned 2000 total points
ID: 37035655
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
 

Author Comment

by:ssmith94015
ID: 37039577
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
 

Author Closing Comment

by:ssmith94015
ID: 37039719
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
 

Author Comment

by:ssmith94015
ID: 37039759
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
 
LVL 10

Expert Comment

by:broro183
ID: 37050485
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

Featured Post

Upgrade your Question Security!

Your question, your audience. Choose who sees your identity—and your question—with question security.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

621 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question