We recently migrated from XP/Office 2003 Â Â to W7/Office 2010.
We are running our projects as mdb under Access 2010.
Am testing a project and getting an error under Access 2010.
Think this is related to how defined Excel objects in the vba.
Am getting the error on the second record, so am thinking maybe did not "finish up" the previous row properly.
Yet cannot find the error. Hope you can help.
Background:
===========
I work for a college. Once a year we send the instructors the course catalog description and detail about the course
for them to review and update. Any updates we data entry via a Web based system.
Am using  Excel as a "report writer tool" and am hiding grid lines so that it looks like a report.
For each course-id-row read, the course id key is compared to the hold-key.
If there is a control-key break, then finish processing, and save the excel spreadsheet as a pdf.
The first course id, processed nicely, detected a new row, and went to finish off old key processing and creating a pdf.
When I process the second course id, am getting the error.
Below is uploaded:
  1) test mdb:
  2) xlt  excel file template
Â
 please click on the form, mark 2 for how many to process, than click ok to process
You will see the first excel sheet create successfully
     then the mdb will stop, if you go to the vba you will see the error.
First I had this:
           objExcelActiveWs.Cells(27, 1).Value = rst!Course
then changed to:
        objExcelActiveWs.Range("A27").Value = rst!Course
Still getting error on second row.
When I click end, and then F5, it does ignore the error.
However, really want to solve the error so that the user does not have to hit F5 for a long time.
the Init      New Key routine is here:  c056_InitNewKey
The finish off old Key routine is here: Â c055_FinishOldKey
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
With all due respect to Martin, I am not sure that you want to suppress the error as much as fix it.
Martin Liss
You say
please click on the form, mark 2 for how many to process, than click ok to process
1. By "form" do you mean the Course_Template sheet?
2. If so then when you say "mark" are you referring to range B2? If so then how do I add the checkmark?
3. Where is "OK"?
Martin Liss
With all due respect to Martin, I am not sure that you want to suppress the error as much as fix it.
I totally agree, I just wanted to see if he'd get any other error and if the results were correct.
This is the best money I have ever spent. I cannot not tell you how many times these folks have saved my bacon. I learn so much from the contributors.
rwheeler23
Martin Liss
@mytfein: Your workbook wound up having no code when I downloaded and opened it. Please include an xlsm file with a shorter name.
mytfein
ASKER
Hi Gentlemen,
Thx so much for replying,
Pls give me a few minutes, to read your answers...
will be right back
tx, sandra
mytfein
ASKER
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
Unlimited question asking, solutions, articles and more.
mytfein
ASKER
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
mytfein
ASKER
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
All of life is about relationships, and EE has made a viirtual community a real community. It lifts everyone's boat
William Peck
Martin Liss
Set a breakpoint on the first bad line and see what if anything is in rst!Schedule. Does your recordset contain any records? Are you passed EOF?
Martin Liss
Can you please post the code for the FillExcel sub?
mytfein
ASKER
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)
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(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
' 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
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 = pg_strFullPathTarget_PDF &Â _
          pg_strInstructorLastFirst & _
          "_" & _
          strHoldKey & _
          "_" & _
          pg_strInstructorSid & _
          ".xls"
' 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
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)
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
 Â
'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)
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)
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
'
'' https://www.experts-exchange.com/questions/24184564/Detect-and-convert-uppercase-but-not-number-in-a-string.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 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
Unlimited question asking, solutions, articles and more.
Martin Liss
That's too much for me to follow. Did you try the breakpoint?
mytfein
ASKER
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.