Splitting up "If... End If", just need a hint.

[Zeke269]

Greetings,

I've inherited an Access 97 database that I'm trying to convert to 2003. One of the Functions appears to have been written by Leo Tolstoy and it will not compile (too large). I know the function needs to be split up, but I'm not familiar enough with VBA to recognize logical break points to produce the sub functions. This thing is loaded to the brim with 'If...End If' statements.. so I'm wondering if the sections of code that are framed by the 'If' and 'End If' can be made into their own function or sub? Or are there other things I should look for to try and break it apart? Maybe breaking after a Loop?

I guess what I'm hoping is to be able to copy the If statements, put them in their own function, and then replace the original position with a call to that function.

Does that sound like a logical way to proceed?

Thanks in advance.

 

[TheAceMan1]

How are ya Zeke269 . . .

. . . and how about posting the code!

See Ya! . . . . . .

Be sure to see FAQ219-2884:

 

[mikej336]

Ace is correct, without seeing the code we would have no way to advise you.

If you see several repetitive things in the code then it might be possible to seperate the repetitive parts into subs or functions. And there might be other ways to clean up the code.

Mike

 

[JoeAtWork]

Yes, you are on the right path.

You should take the approach that each subroutine/function should do one very specialized job and nothing more. Usually code that is deeply indented with If..End If and loops is an indication that too much is being done in the procedure.

First, identify what the subroutine is supposed to do. You should be able to clearly describe it's function in one or two sentences.

Then, look at the code, and "outsource" anything that does not immediately have to do with the subroutine's main purpose.

For example, let's say you have a Save() function that is supposed to save changes to the database. A poorly written megolithic function may be something like this:

Private Sub Save()
  'Does user have the rights to make changes?
  .... lines of code here that opens an Employee's ......
  .... recordset and checks if they have MakeChanges ....
  .... rights ...........................................

  'Are all fields properly filled in according to 
  'the business rules of the application?
  .... many lines of code validating each field, if .....
  .... all are valid a flag variable is set to True .....

  'Save the record
  .... The core code that does this subroutine's job .....
End Sub

In the above procedure, checking permissions and validating the fields is not Save function's responsibility, those jobs should be "outsourced". As per the following example:

Private Sub Save()
  'Does user have the rights to make changes?
  If CheckPermissions("Save") = False Then
    Exit Sub
  End If

  'Are all fields properly filled in according to 
  'the business rules of the application?
  If ValidateFields = False Then
    Exit Sub
  End If

  'Save the record
  .... The core code that does this subroutine's job .....
End Sub

Regarding your question of copying the code inside your If-EndIf blocks, you probably can, make sure to declare all variables that are inside the If-EndIf block and that they are populated the same as in the original code.

What is better than simply copying the code is understanding what it does and then reproducing the functionality in a new subroutine.

If your code is very deeply nested, you may go through this process again in your new subroutines.

 

[Zeke269]

Sorry about not posting the code... it wasn't handy when I posted the question. This is a mess - and yes it needs re-written... but our office is inheriting work faster than we can handle and we just don't have the time right now to do a complete redesign.

How many lines do you want to see? The code itself is 79k. When they built it, they declare a bunch of stuff at the very beginning, keep it open throughout the function, and close at the end. I've considered trying to make the header Public and then start breaking it apart.

Function BtnMatchColumnSystem()
'On Error GoTo err_BtnMatchColumnSystem
  Dim OBL As Recordset, Source As Recordset, Sourceq As Recordset, EOR As Recordset, MainLine As Recordset
  Dim nullSYSTEMNAME As String, wSYSTEMNAME As String, ySYSTEMNAME As String, dSYSTEMNAME As String, qSYSTEMNAME As String, xSYSTEMNAME As String, hSYSTEMNAME As String, zSYSTEMNAME As String, tSYSTEMNAME As String
  nullSYSTEMNAME = "654"
  wSYSTEMNAME = "645"
  ySYSTEMNAME = "645"
  dSYSTEMNAME = "615"
  qSYSTEMNAME = "644"
  xSYSTEMNAME = "644"
  hSYSTEMNAME = "654"
  zSYSTEMNAME = "654"
  tSYSTEMNAME = "615"
  m1 = "Matching data . . . "
  DoCmd.OpenForm "Please Wait"
  DoCmd.RepaintObject acForm, "Please Wait"
  DoCmd.Hourglass True
  DoCmd.SetWarnings False
  DoCmd.RunSQL "Delete * from OBLTmp;"
  'extract only valid records from OBL file to local table - add rollup amt by crn
  ' myb = CurrentDb; myOBL = attached OBL database; my110 = attached Source database.
  q = "INSERT INTO OBLTmp ( ORN, LINEID, CRN, Item, SI, CD, SC, OT, OrderNum, SJO, EOR, TRN, CCM, IFS_M, OBL, OBLAmt, OrigOBLAmt, PP, PPAmt, OrigPPAmt, AFD, NetOBL, OrigNetOBL ) "
  q = q + "SELECT OBL.ORN, OBL.LINEID, OBL.CRN, OBL.Item, OBL.SI, OBL.CD, OBL.SC, OBL.OT, OBL.OrderNum, OBL.SJO, OBL.EOR, OBL.TRN, OBL.CCM, OBL.IFS_M, OBL.OBL AS OBL, cvtnlast([OBL]) AS OBLAmt, cvtnlast([OBL]) AS OrigOBLAmt, OBL.PROG_PAY AS PP, cvtnlast([PROG_PAY]) AS PPAmt, cvtnlast([PROG_PAY]) AS OrigPPAmt, OBL.AFD, NetOBLByOrnLINEIDCrn.NetOBL, NetOBLByOrnLINEIDCrn.NetOBL "
  q = q + "FROM (OBL INNER JOIN NetOBLByOrnLINEIDCrn ON (OBL.LINEID = NetOBLByOrnLINEIDCrn.LINEID) AND (OBL.ORN = NetOBLByOrnLINEIDCrn.ORN) AND (OBL.CRN = NetOBLByOrnLINEIDCrn.CRN) AND (OBL.OT = NetOBLByOrnLINEIDCrn.OT) AND (OBL.SC = NetOBLByOrnLINEIDCrn.SC)) LEFT JOIN MyBadItem ON OBL.Item = MyBadItem.Item "
  q = q + "WHERE (((OBL.Item) Is Not Null) AND ((MyBadItem.Item) Is Null)) OR (((OBL.Item) Is Not Null) AND ((MyBadItem.NotUsedFor)<>""Auto"" And (MyBadItem.NotUsedFor)<>""Both""));"
  DoCmd.RunSQL q
  'get date OBL file loaded
  OBLload = DMax("[OBLLoaded]", "OBL")
  Set myb = CurrentDb
  Set ta = myb.OpenRecordset("MyCccTransCodes", dbOpenDynaset)
  Do While Not ta.EOF
    If ta!CccValue = "Blank" Then
      nullSYSTEMNAME = ta!SYSTEMNAME
     ElseIf ta!CccValue = "W" Then
      wSYSTEMNAME = ta!SYSTEMNAME
     ElseIf ta!CccValue = "Y" Then
      ySYSTEMNAME = ta!SYSTEMNAME
     ElseIf ta!CccValue = "D" Then
      dSYSTEMNAME = ta!SYSTEMNAME
     ElseIf ta!CccValue = "Q" Then
      qSYSTEMNAME = ta!SYSTEMNAME
     ElseIf ta!CccValue = "X" Then
      xSYSTEMNAME = ta!SYSTEMNAME
     ElseIf ta!CccValue = "H" Then
      hSYSTEMNAME = ta!SYSTEMNAME
     ElseIf ta!CccValue = "Z" Then
      zSYSTEMNAME = ta!SYSTEMNAME
     ElseIf ta!CccValue = "T" Then
      tSYSTEMNAME = ta!SYSTEMNAME
    End If
    ta.MoveNext
  Loop
  Set ta = Nothing
  Set my110 = DBEngine.Workspaces(0).OpenDatabase(Forms!switchboard!MySourceLoc)
  Set myarcs = DBEngine.Workspaces(0).OpenDatabase(Forms!switchboard!MyArcsLoc)
  Sourcetable = Forms!switchboard!MySc + "-Source"
  Set Sourceq = myb.OpenRecordset("SourceSYSTEMNAME", dbOpenDynaset)
  Set Source = my110.OpenRecordset(Sourcetable, dbOpenTable)
  Source.Index = "PrimaryKey"  'LinkKey Field - AutoNumber Unique
  Set EOR = myarcs.OpenRecordset("MyEorDefaults", dbOpenTable)
  EOR.Index = "PrimaryKey"  'FY Field - Unique
  If Sourceq.EOF Then GoTo exit_BtnMatchColumnSystem
  Do Until Sourceq.EOF
    foundmatch = 0
    crsvou = False
    If Sourceq!DovNo Like "9*" Then crsvou = True  'should be a CRS updated voucher
    If InStr(Sourceq!Remarks, "CRS updated") > 0 Then crsvou = True   'should be a CRS updated voucher
    If Not IsNumeric(Mid$(Sourceq!DovNo, 2, 1)) Then crsvou = True  'should be a CRS updated voucher
    If Sourceq!LINEID = "ZZ" Then
      Sourceq.Edit
      Sourceq!UpdtReason = "ZZ"
      Sourceq!LedgerKey = "ZZ"
      Sourceq!ArcsLogic = "ZZ"
      Sourceq!LastUpdtBy = "ARC"
      Sourceq!BlkTktNo = Left$(Sourceq!BlkTktNo, 3) + Sourceq!OrigCmdDsg + "ARC"
      Sourceq.Update
    ElseIf (Sourceq!Usn = "W" Or Sourceq!Usn = "Y") And Sourceq!Bsn = "8242" Then 'w=progress pay PAYMENT (TOP of voucher), Y=progress pay RECOUPMENT (BOTTOM of voucher)
      'OPTION FMS
      'if Columbus provides a Item - look for matching Item and progress pay >0 - sort by OBL low to high
      If Sourceq!LenItem > 0 Then
        If Sourceq!ActAmt > 0 Then 'Debit Progress Pay
          q = "SELECT OBLTmp.* FROM OBLTmp WHERE (((OBLTmp.ORN)=""" + Sourceq!OblgRefNoSpiin + """) AND ((OBLTmp.LINEID)=""" + Sourceq!LINEID + """) AND ((OBLTmp.SC)=""" + Sourceq!SiteCode + """) AND ((OBLTmp.Item)=""" + Sourceq!Item + """));"
         Else
          q = "SELECT OBLTmp.* FROM OBLTmp WHERE (((OBLTmp.ORN)=""" + Sourceq!OblgRefNoSpiin + """) AND ((OBLTmp.LINEID)=""" + Sourceq!LINEID + """) AND ((OBLTmp.SC)=""" + Sourceq!SiteCode + """) AND ((OBLTmp.PPAmt)>0) AND ((OBLTmp.Item)=""" + Sourceq!Item + """));"
        End If
        Set OBL = myb.OpenRecordset(q, dbOpenDynaset)
        If Not OBL.EOF Then 'should be on matching OBL record (orn+LINEID+Item) IF ONE EXISTS
          Sourceq.Edit
          Sourceq!CmdDsg = OBL!CD
          Sourceq!BlkTktNo = Left$(Sourceq!BlkTktNo, 3) + OBL!CD + "ARC"
          If Sourceq!Usn = "W" Then
            Sourceq!TrnsCd = wSYSTEMNAME
            Sourceq!UpdtReason = "100-WFms"
            Sourceq!ArcsLogic = "100-WFms"
           Else
            Sourceq!TrnsCd = ySYSTEMNAME
            Sourceq!UpdtReason = "500-WFms"
            Sourceq!ArcsLogic = "500-WFms"
          End If
          
          Sourceq!OBLAmt = OBL!OBLAmt
          Sourceq!OBLDate = OBLload
          Sourceq!ArcsMatchDate = Now
          
          Sourceq!OrderNum = OBL!OrderNum
          Sourceq!EOR = OBL!EOR
          Sourceq!ComtRefNo = OBL!CRN
          Sourceq!CostCenMgr = OBL!CCM
          Sourceq!Qty = "00000000{"
          Sourceq!Item = OBL!Item
          Sourceq!SubOrderNum = OBL!SJO
          Sourceq!IfsDocuNo = OBL!IFS_M
          Sourceq!OkToExport = -1
          foundmatch = -1
          Sourceq!LedgerKey = "100"
          If Forms!switchboard!MyCRSFlag = False And crsvou = True Then
            Sourceq!OkToExport = 0
            Sourceq!LedgerKey = "CRS"
          End If
          Sourceq!SiteCode = OBL!SC
          Sourceq!ArcsAuto = -1
          Sourceq!LastUpdtBy = "ARC"
          Sourceq.Update
          OBL.Edit
          OBL!OBLHits = OBL!OBLHits + 1
          OBL!PPAmt = OBL!PPAmt + Sourceq!ActAmt
          OBL!PP = cvtlast12(OBL!PPAmt)
          'adjust OBL amt
          OBL!OBLAmt = OBL!OBLAmt - Sourceq!ActAmt
          OBL!OBL = cvtlast12(OBL!OBLAmt)
          chgtnet = OBL!NetOBL - Sourceq!ActAmt
          chgfnet = OBL!NetOBL
          chgfcrn = OBL!CRN
          OBL.Update
          OBLUpd = "UPDATE OBLTmp SET OBLTmp!NetOBL = " + Str(chgtnet) + " WHERE (((OBLTmp.CRN)=""" + OBL!CRN + """) AND ((OBLTmp.NetOBL)=" + Str(OBL!NetOBL) + "));"
'          Set OBL = Nothing
          DoCmd.RunSQL OBLUpd, False
      Else 'look for matching 1st 4 of Item - if only one found - post
          If Sourceq!ActAmt > 0 Then 'Debit Progress Pay
            q = "SELECT OBLTmp.* FROM OBLTmp WHERE (((OBLTmp.ORN)=""" + Sourceq!OblgRefNoSpiin + """) AND ((OBLTmp.LINEID)=""" + Sourceq!LINEID + """) AND ((OBLTmp.SC)=""" + Sourceq!SiteCode + """) AND ((OBLTmp.Item) Like """ + Left$(Sourceq!Item, 4) + "*""));"
           Else
            q = "SELECT OBLTmp.* FROM OBLTmp WHERE (((OBLTmp.ORN)=""" + Sourceq!OblgRefNoSpiin + """) AND ((OBLTmp.LINEID)=""" + Sourceq!LINEID + """) AND ((OBLTmp.SC)=""" + Sourceq!SiteCode + """) AND ((OBLTmp.Item) Like """ + Left$(Sourceq!Item, 4) + "*""));"
          End If
          Set OBL = myb.OpenRecordset(q, dbOpenDynaset)
          If Not OBL.EOF Then OBL.MoveLast 'should be on matching OBL record (orn+LINEID+1st 4 Item) IF ONE EXISTS
          If OBL.RecordCount = 1 Then 'only 1 record found
            Sourceq.Edit
            Sourceq!CmdDsg = OBL!CD
            Sourceq!BlkTktNo = Left$(Sourceq!BlkTktNo, 3) + OBL!CD + "ARC"
            If Sourceq!Usn = "W" Then
              Sourceq!TrnsCd = wSYSTEMNAME
              Sourceq!UpdtReason = "200-WFms"
              Sourceq!ArcsLogic = "200-WFms"
            Else
              Sourceq!TrnsCd = ySYSTEMNAME
              Sourceq!UpdtReason = "600-WFms"
              Sourceq!ArcsLogic = "600-WFms"
            End If
          
            Sourceq!OBLAmt = OBL!OBLAmt
            Sourceq!OBLDate = OBLload
            Sourceq!ArcsMatchDate = Now
          
            Sourceq!OrderNum = OBL!OrderNum
            Sourceq!EOR = OBL!EOR
            Sourceq!ComtRefNo = OBL!CRN
            Sourceq!CostCenMgr = OBL!CCM
            Sourceq!Qty = "00000000{"
            Sourceq!Item = OBL!Item
            Sourceq!SubOrderNum = OBL!SJO
            Sourceq!IfsDocuNo = OBL!IFS_M
            Sourceq!OkToExport = -1
            foundmatch = -1
            Sourceq!LedgerKey = "100"
            If Forms!switchboard!MyCRSFlag = False And crsvou = True Then
              Sourceq!OkToExport = 0
              Sourceq!LedgerKey = "CRS"
            End If
            Sourceq!SiteCode = OBL!SC
            Sourceq!ArcsAuto = -1
            Sourceq!LastUpdtBy = "ARC"
            Sourceq.Update
            OBL.Edit
            OBL!OBLHits = OBL!OBLHits + 1
            OBL!PPAmt = OBL!PPAmt + Sourceq!ActAmt
            OBL!PP = cvtlast12(OBL!PPAmt)
            'adjust OBL amt
            OBL!OBLAmt = OBL!OBLAmt - Sourceq!ActAmt
            OBL!OBL = cvtlast12(OBL!OBLAmt)
            chgtnet = OBL!NetOBL - Sourceq!ActAmt
            chgfnet = OBL!NetOBL
            chgfcrn = OBL!CRN
            OBL.Update
            OBLUpd = "UPDATE OBLTmp SET OBLTmp!NetOBL = " + Str(chgtnet) + " WHERE (((OBLTmp.CRN)=""" + OBL!CRN + """) AND ((OBLTmp.NetOBL)=" + Str(OBL!NetOBL) + "));"
'            Set OBL = Nothing
            DoCmd.RunSQL OBLUpd, False
          End If
      End If
    End If

 

[Zeke269]

Greetings and happy (early) Sunday,

Did the following to the "too large" function:

1. Typed "Public" in front of the function name - this was a SWAG on my part and I hope it thereby makes the declarations and such available for all functions.
2. Bookmarked all the Do...Loop sections... seven or eight of them.
3. Cut out the two biggest Do...Loop sections and placed them in their own Functions in a new module.
4. Called these functions from their original locations in the original Function.
5. Compiled - got errors not related to being too large.
6. Commented out a couple lines appearing unrelated functions to force the compile.
7. Compiled again... no errors.

Now - I will caveat this by saying it's yet to be determined that the database will work correctly - I only know it compiled.

Thanks for the tips.