Access 2010 executing Excel VBA: getting error: Application-Defined or Object-Defined error

Hi Gentlemen,

Thx so much for replying,

Pls give me a few minutes, to read your answers...

will be right back

tx, sandra

Hi @Tony,
         Tried your suggestion, still got error

Hi @Martin,
       All the VBA is happening in the Access mdb.

       So if you open mdb:
                         go to forms, run the form

                         The form has a drop down: how many to process:
                         Please choose (instead of Mark :-)  )  2


tx, sandra

Hi Tony,

thx so much....

followed the new suggestions.... same error....

Am not a vba excel expert..... i tried to follow the dimming and setting of the excel variables

in the vba....  must be something wrong there....

will try Martin's idea now.... thx...

sandra

Hi Martin,

tried your suggestion, got the error on the next line after on On Error Go to 0



Thx gentlemen for your ideas

Thx for your understanding about  wanting to keep this question open still...

tx, sandra

Hi Gentlemen,

I have 2 pcs....

Still have the XP pc, and it's giving me an error in A2003 about object variable not being set....

The error is giving me just and OK button not a Debug/End so cannot tell where it is.....

Do not recall this error in the past

Maybe I should debug this in XP as well....

Am thinking to convert this test mdb to work for A2003 and test there....

will be back.... tx...

p.s. this logic is a bit complicated (even for me looking at it a few years after I wrote it... I am parsing a long text file into pieces to place in Excel spreadsheet)

Code to fill spreadsheet:

Option Compare Database

Option Explicit

' these fields are public now in module:  000_MyPublicConstants

Public Sub c050_CreateExcelFancy(blnBackOldCourseFile As Boolean, _
                                 strAttach1 As String, _
                                 strAttach2 As String)

Dim strListBadGrades     As String
Dim strBackSql           As String

Dim strRangeCells        As String
Dim strAcademicYear      As String

Dim strDate              As String

Dim strFullPathTarget    As String
Dim strExcelTemplatePath As String

Dim strPSfile            As String
Dim strLOGfile           As String
Dim strPDFfile           As String


Dim lngPos              As Long
Dim lngResult           As Long

Dim lngColorIndex       As Long

         
SysCmd acSysCmdSetStatus, " "

pg_lngProcessCount = 0
pg_lngEmailCount = 0

'delete instructor table   comment keep bec modifying it in the view Courses screen
' Call q715_DeleteFrom_Table(pg_strTableName_Instructor)

'delete email invalid table
' Call q715_DeleteFrom_Table(pg_strTableName_EmailInvalid)

' launch Excel
Call e090_LaunchExcel


'========================
'processing

Debug.Print strAttach1
Debug.Print strAttach2

Call fillExcel(blnBackOldCourseFile, _
               strAttach1, _
               strAttach2)



' close excel
SysCmd acSysCmdSetStatus, " "

Call e115_JustQuitExcel(True, _
                        blnBackOldCourseFile)
                       
Debug.Print "x"

End Sub


Public Sub fillExcel(blnBackOldCourseFile As Boolean, _
                     strAttach1 As String, _
                     strAttach2 As String)

'====
Dim db                 As DAO.Database
Dim rst                As DAO.Recordset
Dim qdf                As DAO.QueryDef

Dim t                  As DAO.TableDef
Dim fld                As DAO.Field

Dim strHoldKey           As String

Dim lngFirstRow         As Long
Dim lngColCount         As Long
Dim lngRecordCount      As Long
Dim lngDescBaseRowCount         As Long

Dim blnBackGoodIO       As Boolean

             
Dim varBackDesc         As Variant

lngRecordCount = 0

lngColCount = 0
lngDescBaseRowCount = 2

pg_lngLastRowAll = 0


pg_strQueryName_Input = "QP_010_UPD_Replace_CRLF_chars"

DoCmd.SetWarnings False
DoCmd.OpenQuery pg_strQueryName_Input
DoCmd.SetWarnings True




pg_strQueryName_Input = "QP_015_fields_permission_and_section_and_slot_preReq"

Set db = CurrentDb()
Set qdf = db.QueryDefs(pg_strQueryName_Input)
Set rst = qdf.OpenRecordset


       
Debug.Print "========begin======== " & Now


Do Until rst.EOF
                 
   lngRecordCount = lngRecordCount + 1
   
' If rst!Course <> "EMED 4038" Then
'    Debug.Print rst!Course
'
'    GoTo nextrec
' End If


 If Len(pg_varSubject) > 0 Then
     If rst!Course > pg_varSubject & " " & pg_varNumber Then
        Debug.Print rst!Course
     Else
        GoTo nextrec
     End If
 End If

   'control break on student id
   If rst!Course <> strHoldKey Then
   
      pg_lngProcessCount = pg_lngProcessCount + 1
     
       
      SysCmd acSysCmdSetStatus, "Processing: " & _
                           " " & _
                           pg_lngProcessCount & _
                           " " & _
                           pg_strInstructorLastFirst & _
                           " " & _
                           strHoldKey

                           
                           '"of " & _
'                           Me!hdrTotShown & " " & _

 
      If pg_lngProcessCount > 1 Then
          Call c055_FinishOldKey(strHoldKey, _
                                 strAttach1, _
                                 strAttach2)
         
         
          If pg_strProcessCount = pgc_strAll Then
          ElseIf pg_lngProcessCount <= CLng(pg_strProcessCount) Then
          Else
              ' stop if reached max number to process
             GoTo reset
          End If
           
         
         
         
         
          Call c056_InitNewKey(rst!Course, _
                               rst!AcademicYearDesc, _
                               blnBackOldCourseFile)
          If blnBackOldCourseFile = True Then
             GoTo reset
          End If
      Else
     
          Call c056_InitNewKey(rst!Course, _
                               rst!AcademicYearDesc, _
                               blnBackOldCourseFile)
          If blnBackOldCourseFile = True Then
             GoTo reset
          End If
      End If
             
   
   ' save new student id
        strHoldKey = rst!Course
                                         
                                         
        objExcelActiveWs.Range("A27").Value = rst!Course
        objExcelActiveWs.Range("B27").Value = rst!Title
        objExcelActiveWs.Range("D27").Value = rst!Schedule
        objExcelActiveWs.Range("E27").Value = rst!Method
       
             
       
        If rst!BillingMinimum <> rst!MaxCredits Then
           objExcelActiveWs.Range("C29").Value = rst!BillingMinimum & ", " & rst!MaxCredits
        Else
           If Len(rst!BillingMinimum) > 0 Then
              objExcelActiveWs.Range("C29").Value = rst!BillingMinimum
           Else
              objExcelActiveWs.Range("C29").Value = rst!MaxCredits
           End If
        End If
   
       
        objExcelActiveWs.Range("C30").Value = rst!MaxEnroll
             
       
        If rst!PreReq1 = " " Then
           objExcelActiveWs.Range("B33").Value = "NONE"
        Else
           objExcelActiveWs.Range("B33").Value = rst!PreReq1
        End If
       
           objExcelActiveWs.Range("B34").Value = rst!PreReq2
           objExcelActiveWs.Range("B35").Value = rst!PreReq3
       
        objExcelActiveWs.Range("C33").Value = rst!PreReq4
        objExcelActiveWs.Range("C34").Value = rst!PreReq5
        objExcelActiveWs.Range("C35").Value = rst!PreReq6
       
        objExcelActiveWs.Range("D33").Value = rst!PreReq7
        objExcelActiveWs.Range("D34").Value = rst!PreReq8
        objExcelActiveWs.Range("D35").Value = rst!PreReq9
       
        objExcelActiveWs.Range("E35").Value = rst!PreReq10
               
   End If
   

   
               
' trim removes extra spaces at beg and end
  pg_strInstructor = Trim(rst!Instructor)
 
       
  If Len(rst!InstructorSid) > 0 Then
     pg_strInstructorSid = rst!InstructorSid
  End If
     
  If Len(rst!InstructorLastFirst) > 0 Then
     pg_strInstructorLastFirst = rst!InstructorLastFirst
  End If
 
  If Len(rst!Email) > 0 Then
     pg_strInstructorEmail = rst!Email
  End If
 
  If Len(rst!Phone) > 0 Then
     pg_strInstructorPhone = rst!Phone
  End If
     
  Call q840_Select_Table_Instructor _
                            (pg_strTableName_Instructor, _
                             Format(Date, "mm/dd/yyyy"), _
                             pg_strUserName, _
                             rst!Course, _
                             blnBackGoodIO)


         
  If blnBackGoodIO = False Then
     Call q105_InsertInto_Table_Instructor(pg_strTableName_Instructor, _
                                           Format(Date, "mm/dd/yyyy"), _
                                           pg_strUserName, _
                                           rst!Course, _
                                           pg_strInstructorSid, _
                                           pg_strInstructorLastFirst, _
                                           pg_strInstructorEmail, _
                                           pg_strInstructorPhone) _

  Else
     Call q600_Update_Table_Instructor(pg_strTableName_Instructor, _
                                       Format(Date, "mm/dd/yyyy"), _
                                       pg_strUserName, _
                                       rst!Course, _
                                       pg_strInstructorSid, _
                                       pg_strInstructorLastFirst, _
                                       pg_strInstructorEmail, _
                                       pg_strInstructorPhone)
  End If

     
  If Len(pg_strInstructor) > 0 Then
     objExcelActiveWs.Range("G27").Value = pg_strInstructor
  End If
   
     
  If Len(rst!Street1) > 0 Then
     objExcelActiveWs.Range("G28").Value = rst!Street1
  End If
 
  If Len(rst!Street2) > 0 Then
     objExcelActiveWs.Range("G29").Value = rst!Street2
  End If
 
  If Len(rst!Phone) > 0 Then
     objExcelActiveWs.Range("G30").Value = rst!Phone
  End If
 
  If Len(rst!Email) > 0 Then
     objExcelActiveWs.Range("G31").Value = rst!Email
  End If
 
  If Len(rst!FaxPhone) > 0 Then
     objExcelActiveWs.Range("G32").Value = "FAX: " & rst!FaxPhone
  End If
     
  If Len(rst!Permission) > 0 Then
     objExcelActiveWs.Range("G35").Value = "Special Permission: " & rst!Permission
  Else
     objExcelActiveWs.Range("G35").Value = "Special Permission: NO"
  End If
   
   
nextrec:
   rst.MoveNext
   
Loop
   
   
finishup:

 Call c055_FinishOldKey(strHoldKey, _
                        strAttach1, _
                        strAttach2)


reset:

rst.Close
db.Close

Set fld = Nothing
Set t = Nothing
Set rst = Nothing
Set qdf = Nothing
Set db = Nothing


End Sub


Public Sub c055_FinishOldKey(strHoldKey As String, _
                             strAttach1 As String, _
                             strAttach2 As String)

Dim strBackPDF As String
Dim strBackXLS As String


Call c060_PrintToPdf(strHoldKey, _
                     strBackPDF, _
                     strBackXLS)


If pg_lngEmailMode = 1 Or _
   pg_lngEmailMode = 2 Then   'send email, 3 = just pdf to server

   Call c062_SendLotusEmail(strHoldKey, _
                         strBackPDF, _
                         strAttach1, _
                         strAttach2, _
                         strBackXLS)
End If

Debug.Print "c060 " & strHoldKey

're-initialize templstrate sheet to fill for new key info

Set objExcelActiveWs = objExcel.Sheets("Courses_Template")
objExcelActiveWs.Activate

       
objExcelActiveWs.Cells(28, 2).Value = vbNullString
objExcelActiveWs.Cells(28, 3).Value = vbNullString
objExcelActiveWs.Cells(28, 4).Value = vbNullString
objExcelActiveWs.Cells(28, 5).Value = vbNullString


objExcelActiveWs.Cells(29, 3).Value = vbNullString

objExcelActiveWs.Cells(30, 3).Value = vbNullString

objExcelActiveWs.Cells(31, 2).Value = vbNullString
objExcelActiveWs.Cells(31, 3).Value = vbNullString
objExcelActiveWs.Cells(31, 4).Value = vbNullString
objExcelActiveWs.Cells(31, 5).Value = vbNullString

objExcelActiveWs.Cells(32, 2).Value = vbNullString
objExcelActiveWs.Cells(32, 3).Value = vbNullString
objExcelActiveWs.Cells(32, 4).Value = vbNullString
objExcelActiveWs.Cells(32, 5).Value = vbNullString
             
objExcelActiveWs.Cells(35, 7).Value = "Special Permission: "


Call c085_InitDescToSheet(pg_lngCountFinal)
 
 
're-initialize
pg_strInstructorLastFirst = vbNullString
pg_strInstructorSid = vbNullString
pg_strInstructor = "Unknown_Instructor"

' close excel file

objExcel.DisplayAlerts = False

objExcelActiveWkb.Close

objExcel.DisplayAlerts = True

 
End Sub

Public Sub c056_InitNewKey(strNewKey As String, _
                           varAcademicYear As Variant, _
                           blnBackOldCourseFile As Boolean)

Dim strExcelTemplatePath As String
Dim strFullPathTarget    As String

pg_strAcademicYear = varAcademicYear
pg_strInstructorLastFirst = vbNullString
pg_strInstructorSid = vbNullString
pg_strInstructor = "Unknown_Instructor"
pg_strInstructorEmail = vbNullString
pg_strInstructorPhone = vbNullString

Debug.Print "c056 " & strNewKey

strExcelTemplatePath = CurrentProject.Path & "\xxTemplate_ElectiveCatalog_Profile_ForWeb_byCourse.xlt"

' open workbook container
Set objExcelActiveWkbs = objExcel.Workbooks

' open template file
objExcelActiveWkbs.Add strExcelTemplatePath
Set objExcelActiveWkb = objExcel.ActiveWorkbook

' activate sheet tab
Set objExcelActiveWs = objExcel.Sheets("Courses_Template")
objExcelActiveWs.Activate

Dim blnBackGoodIO  As Boolean

Call q805_Select_Table_Students_MinMinWeeks(pg_strTableName_ElectiveCatalog, _
                                            strNewKey, _
                                            pg_strMinMinWeeks, _
                                            blnBackGoodIO)

Call q810_Select_Table_Students_MaxMaxWeeks(pg_strTableName_ElectiveCatalog, _
                                            strNewKey, _
                                            pg_strMaxMaxWeeks, _
                                            blnBackGoodIO)
     
     
Call q815_Select_Table_Students_MaxMaxEnroll(pg_strTableName_ElectiveCatalog, _
                                            strNewKey, _
                                            pg_strMaxMaxEnroll, _
                                            blnBackGoodIO)
     

If pg_strMinMinWeeks <> pg_strMaxMaxWeeks Then
   objExcelActiveWs.Cells(29, 3).Value = pg_strMinMinWeeks & ", " & pg_strMaxMaxWeeks
Else
    If Len(pg_strMinMinWeeks) > 0 Then
       objExcelActiveWs.Cells(29, 3).Value = pg_strMinMinWeeks
    Else
       objExcelActiveWs.Cells(29, 3).Value = pg_strMaxMaxWeeks
    End If
End If

objExcelActiveWs.Cells(30, 3).Value = pg_strMaxMaxEnroll



Call c065_ProcessCourseText(strNewKey, _
                            blnBackOldCourseFile)

End Sub
Public Sub c060_PrintToPdf(strHoldKey As String, _
                           strBackPDF As String, _
                           strBackXLS As String)
                           

Dim strFullPathTarget As String

Dim lngPos     As Long
Dim lngResult  As Long

Dim strPSfile  As String
Dim strLOGfile As String
Dim strPDFfile As String
Dim strExcelfile As String

Set objExcelActiveWs = objExcel.Sheets("Courses_Template")
objExcelActiveWs.Activate

' add header

With objExcelActiveWs.PageSetup
        .LeftHeader = "page: &P of &N"
       
        .CenterHeader = "xxx" & Chr(10) & _
                        "COLLEGE OF MEDICINE" & Chr(10) & _
                        pg_strAcademicYear & Chr(10) & _
                        "Elective Course Catalog Information"
                       
        .RightHeader = "As of: &D          &T"
End With



' save template file with new name
objExcel.DisplayAlerts = False


lngPos = InStr(pg_strInstructorLastFirst, ".")
If lngPos > 0 Then
   pg_strInstructorLastFirst = Replace(pg_strInstructorLastFirst, ".", "_")
   'pg_strInstructorLastFirst = Left(pg_strInstructorLastFirst, lngPos - 2)
End If

Debug.Print pg_strFullPathTarget_XLS

strFullPathTarget = pg_strFullPathTarget_XLS & _
                    pg_strInstructorLastFirst & _
                    "_" & _
                    strHoldKey & _
                    "_" & _
                    pg_strInstructorSid & _
                    ".xls"


strFullPathTarget = Replace(strFullPathTarget, ", ", "_")
strFullPathTarget = Replace(strFullPathTarget, " ", "_")

strExcelfile = strFullPathTarget

Debug.Print strFullPathTarget
objExcelActiveWkb.SaveAs _
                  FileName:=strFullPathTarget
     

                 
     
     
objExcel.DisplayAlerts = True


'save default printer

pg_strDefaultPrinter = objExcel.ActivePrinter

' create pdf file from xls file by printing to pdf printer
' Create PS, LOG, PDF file names from Excel file name

Debug.Print pg_strFullPathTarget_PDF
Debug.Print pg_strFullPathTarget_XLS

strFullPathTarget = pg_strFullPathTarget_PDF & _
                    pg_strInstructorLastFirst & _
                    "_" & _
                    strHoldKey & _
                    "_" & _
                    pg_strInstructorSid & _
                    ".xls"


strBackXLS = strFullPathTarget

strFullPathTarget = Replace(strFullPathTarget, ", ", "_")
strFullPathTarget = Replace(strFullPathTarget, " ", "_")


lngPos = InStr(strFullPathTarget, ".")
strPSfile = Left(strFullPathTarget, lngPos) & "ps"
strLOGfile = Left(strFullPathTarget, lngPos) & "log"
strPDFfile = Left(strFullPathTarget, lngPos) & "pdf"

strBackPDF = strPDFfile

'Debug.Print strPSfile
'Debug.Print strLOGfile
'Debug.Print strPDFfile

' delete work files
    If dir(strPSfile) <> "" Then
       Kill strPSfile
    End If
   
    If dir(strLOGfile) <> "" Then
       Kill strLOGfile
    End If


If m005_IsAdobeInstalled = True Then
   objExcel.ActivePrinter = m010_ReturnPrinterPort_Adobe        '"Adobe PDF on Ne09:"


' print Excel file to Acrobat PS file

    Dim objPDF_Distiller As PdfDistiller
    Set objPDF_Distiller = New PdfDistiller
     
    ' print is really an export to pdf
    objExcel.ActiveSheet.PrintOut , Copies:=1, _
    PrintToFile:=True, PrToFilename:=strPSfile
     
    ' Convert Acrobat PS file to PDF file
    lngResult = objPDF_Distiller.FileToPDF(strPSfile, strPDFfile, "")
   
    Set objPDF_Distiller = Nothing
Else
    objExcel.Visible = False

    MsgBox "Adobe pdf is not installed... please run on another computer" & _
            vbCrLf & vbCrLf & _
           "Only Excel file created here: " & CurrentProject.Path & _
           vbCrLf & vbCrLf & _
           "Please wait as pgm exits"
   
   
End If
                                 
                                 
'Restore the default settings
objExcel.ActivePrinter = pg_strDefaultPrinter

If dir(strPSfile) <> "" Then
   Kill strPSfile
End If

If dir(strLOGfile) <> "" Then
   Kill strLOGfile
End If

 
' Exit Sub
End Sub

Public Sub c062_SendLotusEmail(strHoldKey As String, _
                               strPDFfile As String, _
                               strAttach1 As String, _
                               strAttach2 As String, _
                               strExcelfile As String)


Dim strEmailTo          As String
Dim blnPromptPassword   As Boolean

Dim lngPos              As Long

If pg_lngEmailMode = 2 Then   ' 2 is test
   pg_strInstructorEmail = pg_varEmailTest & "@downstate.edu"
   
   
   'pg_strInstructorEmail = "anne.shonbrun@downstate.edu"
   'pg_strInstructorEmail = "william.davenport@downstate.edu"
   
End If

Debug.Print pg_strInstructorEmail
lngPos = InStr(pg_strInstructorEmail, "@")
If lngPos = 0 Then
   MsgBox pg_strInstructorLastFirst & _
           vbCrLf & vbCrLf & _
          pg_strInstructorEmail & _
          vbCrLf & vbCrLf & _
          "Email missing @ sign. Bypassing this email" & _
           vbCrLf & vbCrLf & _
          pg_strInstructorEmail
                   
          Call q115_InsertInto_Table_EmailInvalid(pg_strTableName_EmailInvalid, _
                                                  pg_strInstructorSid, _
                                                  pg_strInstructorLastFirst, _
                                                  pg_strInstructorEmail)
                                               
         
         
   Exit Sub
End If

If c100_CountToken(pg_strInstructorEmail, _
                     "@") <> 1 Then
   MsgBox "Email has more than one @ sign. Bypassing this email" & _
           vbCrLf & vbCrLf & _
          pg_strInstructorEmail
         
   Call q115_InsertInto_Table_EmailInvalid(pg_strTableName_EmailInvalid, _
                                                  pg_strInstructorSid, _
                                                  pg_strInstructorLastFirst, _
                                                  pg_strInstructorEmail)
                 
         
   Exit Sub
End If
                     
   
'Exit Sub




pg_lngEmailCount = pg_lngEmailCount + 1

blnPromptPassword = True

'If strHoldKey < "OBGY 4316" Then
'   Exit Sub
'End If

Call L010_prodLotusNotes1(pg_strInstructorEmail, _
                          pg_strInstructor, _
                          strPDFfile, _
                          strAttach1, _
                          strAttach2, _
                          strExcelfile, _
                          strHoldKey, _
                          blnPromptPassword, _
                          "N")

End Sub



Public Function m005_IsAdobeInstalled() As Boolean
Dim strTemp As String

m005_IsAdobeInstalled = False

strTemp = dir("C:\Program Files\Adobe\acrobat*", vbDirectory)

Do Until strTemp = ""
   m005_IsAdobeInstalled = True
   strTemp = dir()
Loop

End Function



Public Function m010_ReturnPrinterPort_Adobe() _
                                           As String


Dim p              As Printer

Dim strPrinterName As String
Dim strPrinterPort As String
Dim strPrinterPlusPort As String


Dim lngCount_byNewLine       As Long
Dim lngPos         As Long


For Each p In Printers
 '  Debug.Print p.DeviceName & " " & p.Port & " "; p.DriverName
   
   lngPos = InStr(1, p.DeviceName, "Adobe")
   If lngPos > 0 Then
   
      strPrinterPort = GetPrinterPort2(p.DeviceName)
     
      strPrinterPlusPort = p.DeviceName & " on " & strPrinterPort
     
'      Debug.Print strPrinterPlusPort
     
      m010_ReturnPrinterPort_Adobe = strPrinterPlusPort
   
      Exit For
   
   End If
   
   
   
Next


End Function

Public Sub c065_ProcessCourseText(strNewKey As String, _
                                  blnBackOldCourseFile As Boolean)

Dim lngSourcePointer      As Long
Dim lngSourceIncrement    As Long

Dim varBackDesc                        As Variant
Dim arrCourseDesc_byNewLine()          As String
Dim arrBackFinalDesc()                 As String

Dim blnBackGoodIO                      As Boolean


Call q835_Select_Table_COURSE_Desc(pg_strTableName_CourseDesc, _
                                   Left(strNewKey, 4), _
                                   Right(strNewKey, 4), _
                                   varBackDesc, _
                                   blnBackGoodIO)


blnBackOldCourseFile = False

If blnBackGoodIO = False Then
   MsgBox "Course Description missing for : " & _
                              strNewKey & _
                              vbCrLf & _
                              vbCrLf & _
                              " Please Contact IT for new Course Desc file" & _
                              " Process is aborting"
   blnBackOldCourseFile = True
   Exit Sub
End If



Call c070_SplitCourseText_byNewLine(varBackDesc, _
                                    arrCourseDesc_byNewLine, _
                                    arrBackFinalDesc)


Call c080_MoveDescToSheet(arrBackFinalDesc, _
                          pg_lngCountFinal)



End Sub
 
 
' http://spreadsheetpage.com/index.php/tip/the_versatile_split_function/


Public Sub c070_SplitCourseText_byNewLine(varText As Variant, _
                                          arrCourseDesc_byNewLine() As String, _
                                          arrBackFinalDesc() As String)
                                         

Dim lngCount_byNewLine   As Long
Dim lngCount_byWork      As Long
Dim lngCount_byFinal     As Long

Dim lngLen               As Long
Dim lngDivisor           As Long

Dim dblDivideResult      As Double
Dim intDivideWhole       As Integer
Dim lngBackDecimalPart       As Long

Dim intCount             As Integer
Dim lngPointer           As Long
Dim strSegment           As String
   

Dim arrWorkDesc()        As String


Dim strParseFlowRow      As String

lngDivisor = 120

arrCourseDesc_byNewLine = Split(varText, "#")

dblDivideResult = 0
lngBackDecimalPart = 0
lngCount_byFinal = 0

'anlyze each new line segment
'many segments are run on, that is greater than lngDivisor
'so have to divide the run ons by lngDivisor
'then check segments for orphaned words that need to retrieve the end from the next
'segment in c090

For lngCount_byNewLine = 0 To UBound(arrCourseDesc_byNewLine)
    Debug.Print Len(arrCourseDesc_byNewLine(lngCount_byNewLine)); arrCourseDesc_byNewLine(lngCount_byNewLine)
   
    lngLen = Len(arrCourseDesc_byNewLine(lngCount_byNewLine))
    If lngLen > lngDivisor Then
       strParseFlowRow = arrCourseDesc_byNewLine(lngCount_byNewLine)
       
       dblDivideResult = lngLen / lngDivisor
       intDivideWhole = Int(dblDivideResult)
       
      ' http://www.vbforums.com/showthread.php?t=378445
             
       Call c075_Extract_Dec_Part(dblDivideResult, _
                           ".", _
                         lngBackDecimalPart)
                           
                           
     
     
' http://www.exceltip.com/st/Array_variables_using_VBA_in_Microsoft_Excel/509.html

' Sometimes it 's not possible to calculate how large tha array variable will need to be.
'In these cases the size of the array variable need to be increased as necessary. When
'you use a ReDim-statement to change the array variable size, the variable contents is also erased.
'to avoid deleting the variable contents when you redim the array variable you will nedd to use the ReDim Preserve-statement
     
      lngPointer = 1
      intCount = 0
      lngCount_byWork = 1
     
      ' declares the array variable again (size+1)
      ReDim Preserve arrWorkDesc(1 To intDivideWhole)
 
     
      For intCount = 1 To intDivideWhole
         
          strSegment = Mid(strParseFlowRow, lngPointer, lngDivisor)
                           
          arrWorkDesc(lngCount_byWork) = strSegment
          Debug.Print arrWorkDesc(lngCount_byWork)
         
          lngCount_byWork = lngCount_byWork + 1
         
         
           
'          If Mid(strParseFlowRow, lngPointer + lngDivisor, 1) <> " " Then
'             lngBlankPos = InStr(strParseFlowRow, lngPointer + lngDivisor, 1)
'
'          End If
'
          lngPointer = lngPointer + lngDivisor
      Next intCount
   
      If lngBackDecimalPart > 0 Then
             strSegment = Mid(strParseFlowRow, lngPointer, lngDivisor)
                 
             ' declares the array variable again (size+1)
             ReDim Preserve arrWorkDesc(1 To intDivideWhole + 1)
               
             arrWorkDesc(lngCount_byWork) = strSegment
      '       Debug.Print arrWorkDesc(lngCount_byWork)
               
      End If
     
     
      ' analyze/re-adjust work table for orphan sentences
     
      Call c090_CheckForOrphanEndBeg(arrWorkDesc)
     
     
      ' move work table segments to next available final table rows
      For lngCount_byWork = 1 To UBound(arrWorkDesc)
       '    Debug.Print arrWorkDesc(lngCount_byWork)
           
           lngCount_byFinal = lngCount_byFinal + 1
           ReDim Preserve arrBackFinalDesc(1 To lngCount_byFinal)
           arrBackFinalDesc(lngCount_byFinal) = arrWorkDesc(lngCount_byWork)
           
       '    Debug.Print arrBackFinalDesc(lngCount_byFinal)
           
      Next lngCount_byWork
     
      Debug.Print "up to here: "; lngCount_byFinal
     
Else
   
        dblDivideResult = 0
        lngBackDecimalPart = 0
   
        ReDim Preserve arrBackFinalDesc(1 To lngCount_byFinal + 1)
       
        'if 2 blank lines, just give one blank row in spreadsheet
        ' so check before bumping up lngCount_byFinal
       
        If lngLen = 0 Then
           Debug.Print arrBackFinalDesc(lngCount_byFinal)
                   
           If arrBackFinalDesc(lngCount_byFinal) <> " " Then
           
              lngCount_byFinal = lngCount_byFinal + 1
              arrBackFinalDesc(lngCount_byFinal) = " "
           Else
              Debug.Print 'already blank line - untouch lngCount_byFinal
             
             
           End If
        Else
       
        'length of segment is exactly length of lngDivisor
       
           lngCount_byFinal = lngCount_byFinal + 1
       
           arrBackFinalDesc(lngCount_byFinal) = arrCourseDesc_byNewLine(lngCount_byNewLine)
           Debug.Print arrBackFinalDesc(lngCount_byFinal)
        End If
       
End If
       

       
Next lngCount_byNewLine
     
     
     
Erase arrWorkDesc() ' deletes the varible contents, free some memory

For lngCount_byFinal = 1 To UBound(arrBackFinalDesc)
    Debug.Print arrBackFinalDesc(lngCount_byFinal)
                     
Next lngCount_byFinal
   
End Sub

Public Sub c075_Extract_Dec_Part(dblNum As Double, _
                                 strSeperator As String, _
                                 lngBackDecimalPart As Long)

Debug.Print dblNum

' lngBackDecimalPart = Int(Split(CStr(dblNum), strSeperator)(1))

Dim strDec   As String
Dim strArray() As String
Dim lngPos     As Long

Dim strBackDecimalPart As String

strDec = CStr(dblNum)
lngPos = InStr(strDec, strSeperator)

If lngPos > 0 Then
   strArray = Split(strDec, strSeperator)

   Debug.Print strArray(0)
   Debug.Print strArray(1)

   strBackDecimalPart = strArray(1)

   lngBackDecimalPart = CLng(Left(strBackDecimalPart, 3))

' lngBackDecimalPart = Int(Split(CStr(dblNum), strSeperator)(1))
Else
  lngBackDecimalPart = 0
End If

End Sub

'Sub GetFileNameList()
'' stores all the filenames in the current folder
'Dim FolderFiles() As String ' declares a dynamic array variable
'Dim tmp As String, fCount As Integer
'    fCount = 0
'    tmp = dir("*.*")
'    While tmp <> Empty
'        fCount = fCount + 1
'        ReDim Preserve FolderFiles(1 To fCount)
'        ' declares the array variable again (size+1)
'        FolderFiles(fCount) = tmp
'        tmp = dir
'    Wend
'    MsgBox fCount & " filenames are found in the folder " & CurDir
'    Erase FolderFiles ' deletes the varible contents, free some memory
'End Sub


Public Sub c080_MoveDescToSheet(arrFinalDesc() As String, _
                                lngBackCountFinal As Long)

Dim lngCount_byFinal      As Long
Dim lngDescBaseRow        As Long
Dim lngRowPointer         As Long

lngDescBaseRow = 39

'=== end loop delete extra line
lngBackCountFinal = UBound(arrFinalDesc)

Debug.Print lngBackCountFinal
Debug.Print arrFinalDesc(lngBackCountFinal)

If arrFinalDesc(lngBackCountFinal) = " " Then
   lngBackCountFinal = lngBackCountFinal - 1
End If


For lngCount_byFinal = 1 To lngBackCountFinal
         
     lngRowPointer = lngDescBaseRow + lngCount_byFinal
     
     Debug.Print lngRowPointer
     
     Debug.Print arrFinalDesc(lngCount_byFinal)
         
     objExcelActiveWs.Cells(lngRowPointer, 2).Value = _
                               arrFinalDesc(lngCount_byFinal) 'dim by 0
                               
     
     'bump up 1, bec. it inserts above current row, so want to go down one
     objExcelActiveWs.Range("B" & lngRowPointer + 1).EntireRow.Insert
                         
                               
     'objExcel.ActiveCell.Offset(1).EntireRow.Insert
     
     
     'http://www.mrexcel.com/forum/showthread.php?t=77371

      '  ActiveCell.EntireRow.Insert
     
     
     Dim strRangeCells As String

     strRangeCells = "B" & lngRowPointer & _
                     ":" & _
                     "J" & lngRowPointer


     Set objExcelRange = objExcelActiveWs.Range(strRangeCells)


     With objExcelActiveWs.Range(strRangeCells)
          .Select
          .Copy
     End With
     
     ' objExcelActiveWs.Cells(lngRowPointer + 1, 2).EntireRow.Insert
       
     strRangeCells = "B" & lngRowPointer + 1 & _
                     ":" & _
                     "J" & lngRowPointer + 1

     With objExcelActiveWs.Range(strRangeCells)
          .Select
          .PasteSpecial Paste:=xlPasteFormats
     End With

     
Next lngCount_byFinal



Debug.Print lngRowPointer

strRangeCells = "A" & lngRowPointer + 1 & _
                ":" & _
                "J" & lngRowPointer + 1

With objExcelActiveWs.Range(strRangeCells)
     .Select
     .EntireRow.Delete
End With


End Sub


Public Sub c085_InitDescToSheet(lngCountFinal As Long)


Dim lngCount_byFinal      As Long
Dim lngDescBaseRow        As Long

lngDescBaseRow = 39


For lngCount_byFinal = 1 To lngCountFinal
                   
     objExcelActiveWs.Cells(lngDescBaseRow + lngCount_byFinal, 2).Value = _
                               vbNullString

Next lngCount_byFinal



End Sub


Public Sub c090_CheckForOrphanEndBeg(arrWorkDesc() As String)

                                   
Dim strCurrentRowLastByte   As String
Dim strWordPart2         As String
Dim strNextRowAdjusted   As String

Dim strNextRowFirstByte  As String
Dim strBackCaseType As String

Dim lngCount_byWork      As Long


Dim lngLen1              As Long
Dim lngPos               As Long

Dim lngMaxTableRows As Long

lngMaxTableRows = UBound(arrWorkDesc)

Debug.Print lngMaxTableRows

For lngCount_byWork = 1 To lngMaxTableRows - 1

     Call c100_ClearDebugWindow
     Debug.Print arrWorkDesc(lngCount_byWork)
     Debug.Print arrWorkDesc(lngCount_byWork + 1)
     
         
     lngLen1 = Len(arrWorkDesc(lngCount_byWork))
     
     strCurrentRowLastByte = Mid(arrWorkDesc(lngCount_byWork), lngLen1)
     
     ' check if current row is complete with a period
     ' if not, might be an orphaned word, so check the next row
     
     Debug.Print strCurrentRowLastByte
     
     strNextRowFirstByte = Left(arrWorkDesc(lngCount_byWork + 1), 1)
             
     ' access is not case sensitive, need to check for 1st char is uppercase
     Call c095_CheckCase(strNextRowFirstByte, _
                         strBackCaseType)

     
     If strBackCaseType = "U" Then
             Debug.Print arrWorkDesc(lngCount_byWork)
             Debug.Print arrWorkDesc(lngCount_byWork + 1)
             Debug.Print "U " & strNextRowFirstByte
     End If
     
' 1
If strCurrentRowLastByte <> "." Then
     '2
     If strBackCaseType = "L" Then      'if next line beg with uppercase, do not adj line
                         
     
        ' check the next row for the first space that start frag without orphan word
        lngPos = InStr(arrWorkDesc(lngCount_byWork + 1), " ")
       
        '3
        If lngPos = 1 Then
           Debug.Print arrWorkDesc(lngCount_byWork + 1)
       
           arrWorkDesc(lngCount_byWork + 1) = Mid(arrWorkDesc(lngCount_byWork + 1), 2)
           
           Debug.Print arrWorkDesc(lngCount_byWork + 1)
     
           '3
           ElseIf lngPos > 0 Then
       
           'get remainder of wordPart2 and save it
           
            Debug.Print arrWorkDesc(lngCount_byWork + 1)
           
           strWordPart2 = Left(arrWorkDesc(lngCount_byWork + 1), _
                                         lngPos - 1)
                                         
           Debug.Print strWordPart2
         
           'add to end of current row, remainder of word from the next row
           
                                         
           arrWorkDesc(lngCount_byWork) = arrWorkDesc(lngCount_byWork) & _
                                         strWordPart2
                                         
                                         
           
           Debug.Print arrWorkDesc(lngCount_byWork)
                                         
           ' remove from next row, the orphanPart2 since added to back of current row
           
           strNextRowAdjusted = Mid(arrWorkDesc(lngCount_byWork + 1), _
                                            lngPos + 1)
                                           
           Debug.Print strNextRowAdjusted
           
           ' xxx.    New Sentence frag
           strNextRowAdjusted = LTrim(strNextRowAdjusted)
           arrWorkDesc(lngCount_byWork + 1) = strNextRowAdjusted
           Debug.Print arrWorkDesc(lngCount_byWork + 1)
           
          '3
           ElseIf lngPos = 0 Then
               ' seg+1 has one word orphan that ends previous line
               Debug.Print "here"  'fall to move entire row
               
               Debug.Print arrWorkDesc(lngCount_byWork)
               Debug.Print arrWorkDesc(lngCount_byWork + 1)
               
               arrWorkDesc(lngCount_byWork) = arrWorkDesc(lngCount_byWork) & _
                                              arrWorkDesc(lngCount_byWork + 1)
                                             
               arrWorkDesc(lngCount_byWork + 1) = " "
                                             
               Debug.Print arrWorkDesc(lngCount_byWork)
               Debug.Print arrWorkDesc(lngCount_byWork + 1)
                                         
           '3
           End If
     
     '2
     Else
       
        'Next row begins with a capital
        Debug.Print "here2" ' fall to move entire row
        Debug.Print arrWorkDesc(lngCount_byWork + 1)
       
       
        Debug.Print arrWorkDesc(lngCount_byWork)
        Debug.Print arrWorkDesc(lngCount_byWork + 1)
       
       'check last char in CURRENT row for cap
        Call c095_CheckCase(strCurrentRowLastByte, _
                            strBackCaseType)

       '1b
        If strBackCaseType = "U" Then
             Debug.Print arrWorkDesc(lngCount_byWork)
             Debug.Print arrWorkDesc(lngCount_byWork + 1)
             Debug.Print "U " & strNextRowFirstByte
             
             'check if first char before space is acronym
             'maybe its an acronym continuation from previous line
             
             lngPos = InStr(arrWorkDesc(lngCount_byWork + 1), " ")
             If lngPos = 0 Then
                lngPos = InStr(arrWorkDesc(lngCount_byWork + 1), ".")
                If lngPos > 0 Then
                   lngPos = lngPos + 1   'to include the period in strWordPart2
                End If
             End If
             
             If lngPos = 0 Then
                lngPos = InStr(arrWorkDesc(lngCount_byWork + 1), ":")
                If lngPos > 0 Then
                   lngPos = lngPos + 1   'to include the period in strWordPart2
                End If
             End If


             If lngPos = 0 Then
                lngPos = InStr(arrWorkDesc(lngCount_byWork + 1), ";")
                If lngPos > 0 Then
                   lngPos = lngPos + 1   'to include the period in strWordPart2
                End If
             End If
             
             If lngPos = 0 Then
                lngPos = InStr(arrWorkDesc(lngCount_byWork + 1), "-")
                If lngPos > 0 Then
                   lngPos = lngPos + 1   'to include the period in strWordPart2
                End If
             End If

             
             
             '2b
             If lngPos > 0 Then
       
               'get remainder of wordPart2 and save it
               
                Debug.Print arrWorkDesc(lngCount_byWork + 1)
               
               strWordPart2 = Left(arrWorkDesc(lngCount_byWork + 1), _
                                             lngPos - 1)
                                             
               Debug.Print strWordPart2
               
               Call c095_CheckCase(Left(strWordPart2, 1), _
                                  strBackCaseType)
   
             ' if uppercase, append acronym caps to current row
                  '3b
                    If strBackCaseType = "U" Then
         
                          'add to end of current row, remainder of word from the next row
                                                     
                           arrWorkDesc(lngCount_byWork) = arrWorkDesc(lngCount_byWork) & _
                                                      strWordPart2
                       
                          Debug.Print arrWorkDesc(lngCount_byWork)
                                                         
                        ' remove from next row, the orphanPart2 since added to back of current row
                       
                          strNextRowAdjusted = Mid(arrWorkDesc(lngCount_byWork + 1), _
                                                         lngPos + 1)
                                                         
                          Debug.Print strNextRowAdjusted
                       
                         ' xxx.    New Sentence frag
                          strNextRowAdjusted = LTrim(strNextRowAdjusted)
                          arrWorkDesc(lngCount_byWork + 1) = strNextRowAdjusted
                          Debug.Print arrWorkDesc(lngCount_byWork + 1)
                    '3b
                   End If
           '2b
           End If
        '1b
        Else
       
            lngPos = InStr(arrWorkDesc(lngCount_byWork + 1), " ")
       
            '1c
            If lngPos = 1 Then
               Debug.Print arrWorkDesc(lngCount_byWork + 1)
           
               arrWorkDesc(lngCount_byWork + 1) = LTrim(arrWorkDesc(lngCount_byWork + 1))
               
               Debug.Print arrWorkDesc(lngCount_byWork + 1)
            '1c
            End If
           
       
       
       
        '1b
               
        End If
 


    '2
    End If
   
'1
Else 'prev line ends in period, and next line might start with blank
       

'====
     '1cc
          Debug.Print arrWorkDesc(lngCount_byWork + 1)
       
           arrWorkDesc(lngCount_byWork + 1) = LTrim(arrWorkDesc(lngCount_byWork + 1))
           
           Debug.Print arrWorkDesc(lngCount_byWork + 1)
     


'====



'1
End If
       

       
       
       
       

     
     
     
     'replace 2 dupes with 1
     arrWorkDesc(lngCount_byWork) = Replace(arrWorkDesc(lngCount_byWork), "  ", " ")
     arrWorkDesc(lngCount_byWork + 1) = Replace(arrWorkDesc(lngCount_byWork + 1), "  ", " ")
     
     'replace 3 dupes with 1
     arrWorkDesc(lngCount_byWork) = Replace(arrWorkDesc(lngCount_byWork), "   ", " ")
     arrWorkDesc(lngCount_byWork + 1) = Replace(arrWorkDesc(lngCount_byWork + 1), "   ", " ")
       

             
     
     Debug.Print arrWorkDesc(lngCount_byWork)
     Debug.Print arrWorkDesc(lngCount_byWork + 1)
     
     
     
         
Next lngCount_byWork

' Erase arrWorkDesc

Call c100_ClearDebugWindow

For lngCount_byWork = 1 To UBound(arrWorkDesc)
'     arrWorkDesc(lngCount_byWork) = arrWorkDesc(lngCount_byWork2)

     'remove beg blank from line

'       Debug.Print arrWorkDesc(lngCount_byWork)
'
'     If Left(arrWorkDesc(lngCount_byWork), 1) = " " Then
'        Debug.Print arrWorkDesc(lngCount_byWork)
'        arrWorkDesc(lngCount_byWork) = Left(arrWorkDesc(lngCount_byWork), 1)
'     End If
         
     Debug.Print arrWorkDesc(lngCount_byWork)
         
Next lngCount_byWork


End Sub


Public Sub c095_CheckCase(strChar As String, _
                          strBackCaseType As String)
                         
Debug.Print Asc(strChar)
If Asc(strChar) >= Asc("A") And _
   Asc(strChar) <= Asc("Z") Then
     ''You would also write this as If KeyAscii >= 65 And KeyAscii <= 90
   strBackCaseType = "U"
Else
   strBackCaseType = "L"
End If
                         
End Sub
'
'' http://www.experts-exchange.com/Microsoft/Development/MS_Access/Q_24184564.html?sfQueryTermInfo=1+10+30+test+uppercas
'
'Private Sub Text0_KeyPress(KeyAscii As Integer)
'
''The Asc() function returns the numerical ASCII value of a character,
''You would also write this as If KeyAscii >= 65 And KeyAscii <= 90
''Capital A's value is 65, B is 66, etc; lower case a's value is 90, b is 91, etc.
''Therefore to convert a single character to lower case add 32
''(A = 65) + 32 = (90 = a)
'If KeyAscii >= Asc("A") And KeyAscii <= Asc("Z") Then
'    KeyAscii = KeyAscii + 32
'End If
'End Sub
'
'
'End Sub
'

Public Sub c100_ClearDebugWindow()

Dim i As Integer

For i = 0 To 10
     Debug.Print
Next

Debug.Print "======================================================="

End Sub

Public Function c100_CountToken(strText As String, _
                                strSearch As String) As Long

     Dim i        As Long
     Dim lngCount As Long

     For i = 1 To Len(strText)
          If Mid(strText, i, 1) = strSearch Then
              lngCount = lngCount + 1
          End If
     Next i
 
     c100_CountToken = lngCount

End Function

Hi Martin,

yes you are right it's too much....

Am getting confused....  sigh....   the XP error did not happen again.....

Other "interesting" things are happening... that cannot put finger on....

My colleague in IT gives me an xls file of very long course descriptions. New line is represented by a funny character when I open excel in XP.

So I can look at my parsing logic and the funny character and follow along.

When I open the xls file in Excel 2010 the funny new line character is not there so harder for me to follow along. In fact, am unsure if the new line character is "there", bec my logic created results that were not expected.

So short term, bec manager needs this to go out... scrambled back to XP to test and create/email the excel reports by course id from xp.

It's almost the end of the work day here.... so am going to take a rest from it.... and come back
tommorrow with a fresher mind.

Thx everyone for your help today....

sandra

:-)

Hi Gentlemen,

will close this out as solved

yet want to post it again with simpler English, and trying more debugging first...

tx, sandra

Hi Martin,

there are other work issues that need attention,
so will read your debugging article ...

tx so much!
sandra