Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Westi on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Dirty dirty loop 1

Status
Not open for further replies.
ItIsHardToProgram

ItIsHardToProgram

Technical User
Mar 28, 2006
946
CA
Hey everyone! I programmed a VBA "manual" loop to store some specific query related data in an excel spreadsheet, where a specific criteria matches.

It is very dirty, and before I run it and try it out, I want to make sure this is the best way to do what I want to do. I seriously doubt it, and I want some expert to maybe "clean up" or at least point me in a better direction. If my process is sound and works, then cheers.

Here is what I am doing:

Code: 
Function TransfertExcelAutomation(strSQL As String, _
sEmplacement As String)

On Error GoTo err_Handler

    'Excel object variables
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    
    Dim sTemplate As String
    Dim sTempFile As String
    Dim sOutput As String
    
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim sSQL As String
    Dim IRecords As Long
    Dim iRow As Integer
    Dim iCol As Integer
    Dim iFld As Integer
    Dim ProjectID As String
    
    Dim i As Integer
    
    Const cTabOne As Byte = 1
    Const cTabTwo As Byte = 2
    Const cStartRow As Byte = 3
    Const cStartColumn As Byte = 1
    
    iRow = 4
    
    DoCmd.Hourglass True
    
    'Set to break on all errors
    Application.SetOption "Error Trapping", 0
    
    'Start with clean file built from template file
    sTemplate = sEmplacement & "\TestTemps.xls"
    sOutput = sEmplacement & "\TestTemps2.xls"
    If Dir(sOutput) <> "" Then Kill sOutput
    FileCopy sTemplate, sOutput
    
    'Create the Excel Application, Workbook and Worksheet and Database object
    Set appExcel = New Excel.Application
    appExcel.Visible = True
    Set wbk = appExcel.Workbooks.Open(sOutput)
    
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
    If Not rst.BOF Then rst.MoveFirst
      'For this template, the data must be placed in the appropriate cells of the spreadsheet
    
    'Do While ProjectID <> ""
        i = 1
ManualLoop:
            Select Case i
                Case 1
FirstProcedure:
                    Do While rst.EOF = False
                        ProjectID = wbk.Worksheets("BrunoSommaire").Cells(iRow, 1)
                        
                        If ProjectID = rst.Fields("IDProjet") Then
                            wbk.Worksheets("SOMMAIRE").Cells(iRow, 9).Value = rst.Fields("Honoraire utilisé")
                        End If
                        
                        rst.MoveNext
                    Loop
                        iRow = iRow + 1
                        
                        If ProjectID = wbk.Worksheets("BrunoSommaire").Cells(iRow, 1) = "" Then
                            GoTo EndOfProcedure
                        End If
                        
                        GoTo FirstProcedure
                    
        
                Case 2
SecondProcedure:
                    Do While rst.EOF = False
                        ProjectID = wbk.Worksheets("NancySommaire").Cells(iRow, 1)
                        
                        If ProjectID = rst.Fields("IDProjet") Then
                            wbk.Worksheets("SOMMAIRE").Cells(iRow, 9).Value = rst.Fields("Honoraire utilisé")
                        End If
                        
                        rst.MoveNext
                    Loop
                        iRow = iRow + 1
                        
                        If ProjectID = wbk.Worksheets("NancySommaire").Cells(iRow, 1) = "" Then
                            GoTo EndOfProcedure
                        End If
                        
                        GoTo SecondProcedure
                Case 3
ThirdProcedure:
                    Do While rst.EOF = False
                        ProjectID = wbk.Worksheets("JefSommaire").Cells(iRow, 1)
                        
                        If ProjectID = rst.Fields("IDProjet") Then
                            wbk.Worksheets("SOMMAIRE").Cells(iRow, 9).Value = rst.Fields("Honoraire utilisé")
                        End If
                        
                        rst.MoveNext
                    Loop
                        iRow = iRow + 1
                        
                        If ProjectID = wbk.Worksheets("JefSommaire").Cells(iRow, 1) = "" Then
                            GoTo EndOfProcedure
                        End If
                        
                        GoTo ThirdProcedure
                Case 4
FourthProcedure:
                    Do While rst.EOF = False
                        ProjectID = wbk.Worksheets("MartinSommaire").Cells(iRow, 1)
                        
                        If ProjectID = rst.Fields("IDProjet") Then
                            wbk.Worksheets("SOMMAIRE").Cells(iRow, 9).Value = rst.Fields("Honoraire utilisé")
                        End If
                        
                        rst.MoveNext
                    Loop
                        iRow = iRow + 1
                        
                        If ProjectID = wbk.Worksheets("MartinSommaire").Cells(iRow, 1) = "" Then
                            GoTo EndOfProcedure
                        End If
                        
                        GoTo FourthProcedure
                Case 5
FifthProcedure:
                    Do While rst.EOF = False
                        ProjectID = wbk.Worksheets("MaSommaire").Cells(iRow, 1)
                        
                        If ProjectID = rst.Fields("IDProjet") Then
                            wbk.Worksheets("SOMMAIRE").Cells(iRow, 9).Value = rst.Fields("Honoraire utilisé")
                        End If
                        
                        rst.MoveNext
                    Loop
                        iRow = iRow + 1
                        
                        If ProjectID = wbk.Worksheets("MaSommaire").Cells(iRow, 1) = "" Then
                            GoTo EndOfProcedure
                        End If
                        
                        GoTo FifthProcedure
                Case 6
SixthProcedure:
                    Do While rst.EOF = False
                        ProjectID = wbk.Worksheets("JimSommaire").Cells(iRow, 1)
                        
                        If ProjectID = rst.Fields("IDProjet") Then
                            wbk.Worksheets("SOMMAIRE").Cells(iRow, 9).Value = rst.Fields("Honoraire utilisé")
                        End If
                        
                        rst.MoveNext
                    Loop
                        iRow = iRow + 1
                        
                        If ProjectID = wbk.Worksheets("JimSommaire").Cells(iRow, 1) = "" Then
                            GoTo EndOfProcedure
                        End If
                        
                        GoTo SixthProcedure
                
                End Select
                
    'Loop
EndOfManualLoop:
    rst.Close
    

exit_Here:
'Cleanup all objects (resume next on errors)
Set wbk = Nothing
appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
i = 0
Exit Function

err_Handler:
    ExportQuery = Err.Description
    Resume exit_Here
 End If

EndOfProcedure:
    Select Case i
        Case 1
            i = 2
            rst.MoveFirst
            GoTo ManualLoop
        Case 2
            i = 3
            GoTo ManualLoop
        Case 3
            i = 4
            GoTo ManualLoop
        Case 4
            i = 5
            GoTo ManualLoop
        Case 5
            i = 6
            GoTo ManualLoop
        Case 6
            GoTo EndOfManualLoop
    End Select
            
            
        
End Function

I am not sure this will perform as I want, but I want to make sure my cpu won't go in an undeniable OverCPUusage.

How long will this process take? Am I seeing it wrong? I've put alot of thought into this, and I am not sure how it will perform. This is run from Access.

Please help me tackle this problem!

Cheers!

Julien

"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.
 
Sort by date Sort by votes


Hi,

I see the

1) SAME or SIMILAR code statements REPEATED

2) GOTO

my instincts say, there IS a better way!

1. Is the order of Bruno, Nancy, etc relevant?

2. Could the output data be intermingled if you looped thru the recordset ONCE and for each record loop thru the Bruno, Nancy... sheets?

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Thanks for a prompt answer skip!

1; The order is in fact not relevant, as you can see, it loops through the whole recordset any way, and each and every employee have their own data sheet.

2; There should not be more than 1 match overall, so I could probably loop through Bruno, nancy etc... sheets, without having intermingled data.

The reason why I have processed like I am processing is the following.

[blue] 1:Not every employee have the same number of projects, thus, if there is no more project, it is useless to keep looping, and could take longer ? (maybe)

2:The number of recordset is not the same than the number of project, EVER, there will be alot more outputs than projects.

3: I want this to be as fast as possible, as it may be ran once a day, and the less buggy the better.[/blue]

Following your line of idea, I would process like this:

Code: 
Do While rst.EOF = False

    For i = 1 To 6
    
        Select Case i
            Case 1
                Do Until ProjectID = ""
                
                ProjectID = wbk.Worksheets("BrunoSommaire").Cells(iRow, 1)
                        
                        If ProjectID = rst.Fields("IDProjet") Then
                            wbk.Worksheets("SOMMAIRE").Cells(iRow, 9).Value = rst.Fields("Honoraire utilisé")
                        End If
                        
                iRow = iRow + 1
                
                Loop
                
                iRow = 4
                
            Case 2
                Do Until ProjectID = ""
                
                ProjectID = wbk.Worksheets("NancySommaire").Cells(iRow, 1)
                        
                        If ProjectID = rst.Fields("IDProjet") Then
                            wbk.Worksheets("SOMMAIRE").Cells(iRow, 9).Value = rst.Fields("Honoraire utilisé")
                        End If
                        
                iRow = iRow + 1
                
                Loop
                
                iRow = 4
                
                etc....
            End Select
Loop

Would this be the more appropriate way of doing things?




"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.
 
Upvote 0 Downvote
Do you have these 2 lines at the top of your code module?
Code: 
Option Compare Database
Option Explicit

Also, I'm assuming this is run in Access, from the way it's all laid out.

If you don't have the 2 lines of code at the top of the module, put them in, and then compile the code (Debug menu - Compile).

You'll find out that at least one of your variables is used, but not defined. Otherwise, I definitely agree with Skip (and would probably be a fool NOT to agree with Skip on his VBA/Office stuff! [wink]).

I've not had time to look at the whole thing in depth. I just simply compiled it on my end to find your missing variable.

--

"If to err is human, then I must be some kind of human!" -Me
 
Upvote 0 Downvote
Well yeah, I do have these lines of code, I actualy am trying to clean the obvious things out before I do all these little fixes, but thanks for your remark! I have noticed the missing variable and changed it.

"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.
 
Upvote 0 Downvote



i would think that you loop could be written more compactly, something like this...
Code: 
    Dim ws As Worksheet, r As Range
    Dim rst As Recordset, lRowOut As Long, lRowIn As Long
    
    lRowOut = 4
    Do
        For Each ws In Sheets(Array("BrunoSommaire", "NancySommaire"))
            For Each r In ws.Range(ws.[A4], ws.[A4].End(xlDown))
                If ws.Cells(r.Row, 1) = rst.Fields("IDProjet") Then
                    wbk.Worksheets("SOMMAIRE").Cells(lRowOut, 9).Value = rst.Fields("Honoraire utilisé")
                    lRowOut = lRowOut + 1
                End If
            Next
        Next
        
        rst.movenext
    Loop Until rst.EOF


Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Wow ok...

There is one thing though, I haven't corrected that, in my code it shows its writting on "SOMMAIRE" but its actualy writting on either BrunoSommaire, NancySommaire, or on wich ever sheet the match was found, on the line of the match.

How would you add that in your compact code? You really mistify me on how you are able to program such compact codes.

"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.
 
Upvote 0 Downvote


Code: 
    Dim ws As Worksheet, r As Range
    Dim rst As Recordset
    
    Do
        For Each ws In Sheets(Array("BrunoSommaire", "NancySommaire"))
            For Each r In ws.Range(ws.[A4], ws.[A4].End(xlDown))
                If ws.Cells(r.Row, 1) = rst.Fields("IDProjet") Then
                    ws.Cells(r.Row, 9).Value = rst.Fields("Honoraire utilisé")
                End If
            Next
        Next
        
        rst.movenext
    Loop Until rst.EOF

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Thanks alot Skip for your help once more!

I really need to learn how to lose arrays like that, any suggestion where to start?

Also, this loops stops as soon as there is nothing in r, right?

Thanks alot of your valuable help!

"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.
 
Upvote 0 Downvote
Erm... not lose, but use ;) !

"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.
 
Upvote 0 Downvote


BTW, here's how to CHECK to be sure a range is properly coded, specifically referring the this range...
Code: 
ws.Range(ws.[A4], ws.[A4].End(xlDown))
You will want to put a BREAK in and then observe if the SELECTION is what you expect...
Code: 
        For Each ws In Sheets(Array("BrunoSommaire", "NancySommaire"))
[b]ws.Range(ws.[A4], ws.[A4].End(xlDown)).Select[/b]
'''break here
[highlight red]            For Each r In ws.Range(ws.[A4], ws.[A4].End(xlDown))[/highlight]
                If ws.Cells(r.Row, 1) = rst.Fields("IDProjet") Then
                    ws.Cells(r.Row, 9).Value = rst.Fields("Honoraire utilisé")
                End If
            Next
        Next

Skip,

[glasses]Just traded in my old subtlety...
for a NUANCE![tongue]
 
Upvote 0 Downvote
Cheers, thanks alot

"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

sxschech
  • Locked
  • Question
For Each Loop works once then gives error 91 2
Replies
19
Views
779
sxschech
sxschech
TenDollarTypo
  • Locked
  • Question
Merge every 9 Cells Loop
Replies
3
Views
219
TenDollarTypo
TenDollarTypo
mohamadmh
  • Locked
  • Question
Improve speed of For i Loop ? Is is possible to use arrays
Replies
9
Views
377
Andrzejek
Andrzejek
simc22
  • Locked
  • Question
Help with VBA find loop?
Replies
5
Views
201
strongm
strongm
mohamadmh
  • Locked
  • Question
Loop through column a tricky one
Replies
12
Views
283
Andrzejek
Andrzejek

Part and Inventory Search

Sponsor

Back
Top