• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 331
  • Last Modified:

VBA code in Access 2010 used to work in 2003, but not now

I recently dug up a database that was created in Access 2003, and it had some code that would export data to Excel 2003, and then format the worksheet.  Well since that time, my company is now using both Access 2010, and Excel 2010.  When I try to run the code (in the click event of an Access button), I get the following error:

  "Run-time error '1004'
   Application-defined or object defined error"

When I go to debug, line 104 is highlighted.  I have already worked through a few other bugs, but I can't figure this one out.  I had to change the variable "wks" from being declared as a worksheet to being declared as an object.  Not sure why.  I coded around line 104 just to see if the rest of the code would run, and it did with the exception of line 133, which is the exact same code as line 104, and lines 159 and 166.  I can ask new questions for those after I have resolved the issue of line 104.

Any and all help is much appreciated!

Thanks - Hubbs
Private Sub cmdFundedRpt_Click()

'This is the Funded Report

Dim rsAct As DAO.Recordset
Dim rsCat As DAO.Recordset
Dim i As Integer, j As Integer, shtCnt As Integer
Dim colCnt, rowCnt, iCol, iRow
Dim xlObj As Object, nSheet As Object
Dim sqlCat As String
Dim sSql As String
Dim Catcnt As Integer

txtNameEnd = Format(Now(), "mmddyy_hh_nn_ss")
 
'add a new excel file
Set xlObj = CreateObject("excel.application")
    xlObj.Workbooks.Add
 

    sSql = "SELECT * FROM qryActivity ORDER BY SortOrder, VCC_LnNum"
    
    Set rsAct = CurrentDb.OpenRecordset(sSql)
    Set nSheet = xlObj.ActiveWorkbook.Sheets("sheet1")
    
    sqlCat = "SELECT DISTINCT Category FROM qryActivity"
    Set rsCat = CurrentDb.OpenRecordset(sqlCat)
    
    If rsCat.EOF Then Exit Sub
    rsCat.MoveLast
    Catcnt = rsCat.RecordCount
 
    'rename the sheet
    nSheet.Name = ("SS_Activity")
 
    'copy the headers
        For iCol = 0 To rsAct.Fields.Count - 1
            nSheet.Cells(1, iCol + 1).Value = rsAct.Fields(iCol).Name
        Next
    With nSheet
        .Range("A2").CopyFromRecordset rsAct  'copy the data
    
    'format the sheet
        colCnt = .UsedRange.Columns.Count
        rowCnt = .UsedRange.Rows.Count
        .Range("A1:" & Chr(64 + colCnt) & 1).Interior.ColorIndex = 48
        .Range("A1:" & Chr(64 + colCnt) & 1).Borders.LineStyle = xlContinuous
        .Range("A1:" & Chr(64 + colCnt) & 1).Font.Bold = True
        .Range("A1:" & Chr(64 + colCnt) & rowCnt).Columns.AutoFit
        .Range("B:B").ColumnWidth = 16
        .Range("C:C").ColumnWidth = 35
        .Range("D:D").ColumnWidth = 18
        '.Range("D:D").NumberFormat = "m/d/yyy"
        '.Range("D:D").HorizontalAlignment = xlHAlignCenter
        .Range("E:E").ColumnWidth = 16
        .Range("E:E").NumberFormat = "[$$-409]#,##0.00"
        .Range("F:F").ColumnWidth = 16
        .Range("F:F").NumberFormat = "[$$-409]#,##0.00"
        .Range("G:G").ColumnWidth = 12
        .Range("G:G").NumberFormat = "m/d/yyy"
        '.Range("G:G").HorizontalAlignment = xlHAlignCenter
        .Range("H:H").ColumnWidth = 14
        '.Range("H:H").NumberFormat = "m/d/yyy"
        .Range("I:I").ColumnWidth = 12
        .Range("I:I").NumberFormat = "m/d/yyy"
        .Range("J:J").ColumnWidth = 18
        '.Range("J:J").HorizontalAlignment = xlHAlignCenter
        .Range("K:K").ColumnWidth = 5
        '.Range("K:K").HorizontalAlignment = xlHAlignCenter
        .Range("L:L").ColumnWidth = 12
        .Range("L:L").NumberFormat = "m/d/yyy"
        .Range("M:M").ColumnWidth = 12
        
        
    End With
    
    xlObj.ActiveWorkbook.SaveAs "P:\VCC Servicing\Servicing\SpecServActivity_" & Forms!frmRptGenerator.txtNameEnd & ".xlsx"
    Set nSheet = Nothing
    xlObj.Quit
    'Set xlObj = Nothing
    rsAct.Close
    Set rsAct = Nothing
        
   Dim lngRow As Long, lngRowCount As Long, lngStartRow As Long, lngEndRow As Long
   Dim lngGroupCol As Long, lngCountCol As Long, lngSumCol As Long
   Dim xpath As String
   Dim wks As Object, wbk As Object
   Dim strSubtotalHead As String, strGroupHead As String
   
   xpath = "P:\VCC Servicing\Servicing\SpecServActivity_" & Forms!frmRptGenerator.txtNameEnd & ".xlsx"
   xlObj.Workbooks.Open (xpath)
   Set wbk = xlObj.ActiveWorkbook
   'Set wbk = Workbooks.Open(xpath)
   
   Set wks = wbk.Sheets("SS_Activity")
  
   ' This is the column number of MS_Current
   lngGroupCol = 10
   ' Counting column - Loan_Num
   lngCountCol = 1
   ' Sum column - Loan Amount
   lngSumCol = 5
   ' Get last used row
   lngRowCount = wks.Cells(wks.Rows.Count, lngGroupCol).End(xlUp).Row
   'lngRowCount = 19
   lngEndRow = lngRowCount + 1
   
   With wks
      
      For lngRow = lngRowCount To 2 Step -1
         ' check if Category is the same for both rows
         If .Cells(lngRow - 1, lngGroupCol).Value <> .Cells(lngRow, lngGroupCol).Value Then
            ' If not, add a new row for totals
            '.Rows(lngEndRow).Insert
            .Range(lngEndRow & ":" & lngEndRow + 1).Insert
            ' Fill in count and sum formulas
            .Cells(lngEndRow, "D").FormulaR1C1 = "=subtotal(3,R" & lngRow & "C:R[-1]C)"
            .Cells(lngEndRow, lngSumCol).FormulaR1C1 = "=subtotal(9,R" & lngRow & "C:R[-1]C)"
            .Cells(lngEndRow, "C").Value = .Cells(lngRow, lngGroupCol).Value & " Subtotals:"
            ' Apply formatting to first 9 cells in row - change formats as required
            With .Cells(lngEndRow, 1).Resize(1, 13)
               .Font.Bold = True
               '.Borders.LineStyle = xlContinuous
               .Interior.ColorIndex = 37
            End With
            lngEndRow = lngRow
         End If
      'MsgBox wks.Name
         
      Next lngRow
      
      ' Add Grand totals
      lngRowCount = wks.Cells(wks.Rows.Count, lngSumCol).End(xlUp).Row
      'lngRowCount = 34
      
      With .Cells(lngRowCount + 2, "A")
      .Value = "Funded or Completed Totals:"
      
      ' add formatting out as far as Group column
      With .Resize(1, 13)
            .Interior.ColorIndex = 15
            .Font.Bold = True
         End With
      End With
      
      .Cells(lngRowCount + 2, "D").FormulaR1C1 = "=subtotal(3,R2C:R[-1]C)"
      
      With .Cells(lngRowCount + 2, lngSumCol)
         .FormulaR1C1 = "=SUBTOTAL(9,R2C:R[-2]C)"
         'With .EntireRow
         '   .Interior.ColorIndex = 35
         '   .Font.Bold = True
            '.Borders.LineStyle = xlContinuous
            '.EntireColumn.NumberFormat = "[$$-409]#,##0.00"
         'End With
      End With
         
   End With
   wbk.Save
   
   
   'wks.Activate
      
   wks.Select
   wks.Range("A1").Select
   Selection.EntireRow.Insert shift:=xlShiftDown
   Selection.EntireRow.Insert shift:=xlShiftDown
   Selection.EntireRow.Insert shift:=xlShiftDown
   
   wks.Columns("A:A").Hidden = True
   wks.Range("B2").Value = "Activity Report: " & [Forms]![frmRptGenerator]![txtstartDate] & " To " & [Forms]![frmRptGenerator]![txtendDate]
   wks.Range("B2").Font.Bold = True
   wks.Range("B2").Font.Size = 14
   
         
   ' Save workbook
   
   wbk.Application.Visible = True

   wbk.Save
   
    
   ' Dim xltmp As New Excel.Application
   ' xltmp.Workbooks.Open ("P:\JPH_Data\Sales\Reports\Target_" & Forms!frmRptGenerator.txtNameEnd & ".xls")
        
   ' xltmp.Application.Visible = True
   ' xltmp.Parent.Windows(1).Visible = True


End Sub

Open in new window

0
Hubbsjp21
Asked:
Hubbsjp21
1 Solution
 
mbizupCommented:
Make sure you have set the appropriate references.

From the VBA Editor:

Tools -> references

Update any that are labeled as "MISSING"
0
 
Hubbsjp21Author Commented:
Shame frickin' on me for not looking at that before I did anything else!

Thanks!
0
 
Jeffrey CoachmanCommented:
FWIW:

Dim colCnt, rowCnt, iCol, iRow
...Here these will all be Variants ...Is this what is really needed?



0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now