Advertisement

06.01.2008 at 03:27PM PDT, ID: 23448535
[x]
Attachment Details
[x]
The Solution Rating System

With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.

  • The Grade of the Solution
  • The Zone Rank of the Expert Providing the Solution
  • The Number of Author and Expert Comments
  • The Number of Experts Contributing
  • The Feedback of the Community

Your Input Matters
Because of the way the system is set up, the most important variable in this equation is you. As a member of Experts Exchange, you are able to cast your vote on the quality of the solutions in regard to how complete, accurate, helpful and easy to understand each solution is. When you provide your feedback, each rating is adjusted accordingly. So, if you see a solution that has a poor rating that you think is a good solution, let us know by rating it. As you do, the rating will be adjusted and will become more accurate for other members of our site.

If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support.

Thank you!
9.1

How to avoid the runtime error '1004' - To prevent possible loss of data, Microsoft Access cannot shift nonblank cells of the worksheet ?

Asked by zimmer9 in Microsoft ADP, Microsoft Excel Spreadsheet Software, Access Coding/Macros

I am developing an Access 2003 application using Access and Excel VBA as the front end and SQL Server as the back end database.

I have a subroutine which is called to provide sub totals in an Excel file based on detail records supplied by an Acess table.

The Attached code snippet shows the subroutines I am using.

The compiler stops on the following line which attempts to insert a new row:
the value of lngI is 61,016 and the value of xlDown is -4,121. The full subroutine GenerateTotals
can be found in the attached code snippet.

Private Sub GenerateTotals(objWorkSheet, strGroupColumns, strTotalColumns)
...
 ' Don't attempt to add a sub totals row if this is the first row
            If lngI > FirstRow Then
                ' Insert a new row above the current row number for inserting the subtotals
                objWorkSheet.Rows(lngI & ":" & lngI).Insert (xlDown)
                Start Free Trial 
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:

Private Sub BranchDetailAll()
    Dim cnn As ADODB.Connection
    Dim ExportedFile As String
    Dim strNextFile As String
    Dim rstQueryFS As ADODB.Recordset
    Dim objXL As Excel.Application
    Dim objWS As Excel.Worksheet
    Dim fld As ADODB.Field
    Dim intCol As Integer
    Dim intRow As Integer
    Dim strSQL As String
    Dim intBonds As Integer
    Dim com As ADODB.Command
    Dim P1 As New Parameter
    Dim intReport As Integer
    Const strTable = "tblDtlBranchAll"
    Set cnn = CurrentProject.Connection
    Dim cn As ADODB.Recordset
    
    Set cn = New ADODB.Recordset
    
    cn.ActiveConnection = CurrentProject.Connection
    cn.CursorType = adOpenStatic
    cn.CursorLocation = adUseServer
    cn.LockType = adLockReadOnly
 
    strSQL = "If  Exists(SELECT * FROM dbo.SYSOBJECTS WHERE NAME = 'tblDtlBranchAll' AND TYPE = 'U') DROP TABLE tblDtlBranchAll"
    
    cn.Open strSQL
    
    strSQL = "If  Exists(SELECT * FROM dbo.SYSOBJECTS WHERE NAME = 'tblDtlBrOrder' AND TYPE = 'U') DROP TABLE tblDtlBrOrder"
    
    cn.Open strSQL
       
    DoCmd.Hourglass True
       
    Set com = New ADODB.Command
    With com
       .CommandType = adCmdStoredProc
       .CommandText = "dbo.procNumberOfAccounts"
        Set .ActiveConnection = CurrentProject.Connection
       .Execute
    End With
   
    Set com = New ADODB.Command
    With com
       .CommandType = adCmdStoredProc
       .CommandText = "dbo.procDeleteBrAllRpt"
        Set .ActiveConnection = CurrentProject.Connection
       .Execute
    End With
   
    Set com = New ADODB.Command
    With com
       .CommandType = adCmdStoredProc
       .CommandText = "dbo.procDetailBranchAll"
       .Parameters.Append .CreateParameter("@Branch", adVarChar, adParamInput, 4, strBranch)
       Set .ActiveConnection = CurrentProject.Connection
       .Execute
    End With
    
    strSQL = "select OfficeNumber, CustomerNumber,DateRange,[Property Type],MarketValue into dbo.tblDtlBrOrder From dbo.tblDtlBranchAll order by DateRange Asc, CustomerNumber Asc, MarketValue Desc "
    cn.Open strSQL
    
    ExportedFile = "\\nydfs1\root\lib\CONTROLLERS\IIG\CASH_CONTROL\ccshared\AbandonedProperty\UDL\Access\Reconcile\DTLBRANCHALL" & "_" & intYearSP & "_" & Format(Now, "mmddhhnnss") & ".XLS"
    'DoCmd.TransferSpreadsheet acExport, 8, "tblDtlBrOrder", ExportedFile, True, ""
    Call ExportToExcels(ExportedFile, "OfficeNumber", "tblDtlBrOrder", "60000")         '<---- Call ExportToExcels
   
    'If isFileExist(ExportedFile) Then Calc_subtotals ExportedFile
    
    DoCmd.Hourglass False
End Sub
----------------------------------------------------
Private Sub ExportToExcels(filename As String, FieldToCount As String, TableToCount As String, NumberOfRecords As Long)
    Dim strSelect As String
    Dim strDelete As String
    Dim cn As ADODB.Connection
    Dim xl As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim sht As Excel.Worksheet, rng As Excel.Range
    Dim db As DAO.Database, rs As ADODB.Recordset
    Dim recordtotal As Long
    Dim SheetNum As Long
    Dim dest As Range
    Dim Counter As Long
    Dim Source As Workbook
 
    strSelect = "Select top " & NumberOfRecords & " * from " & TableToCount
    strDelete = "delete from " & TableToCount & " where " & FieldToCount & " in(Select top " & NumberOfRecords & " " & FieldToCount & " from " & TableToCount & ")"
    
    Set cn = CurrentProject.Connection
    Set rs = New ADODB.Recordset
     
    Set db = CurrentDb
     
    recordtotal = DCount(FieldToCount, TableToCount)
    Set xl = CreateObject("Excel.Application")
     
    Set xlWB = xl.Workbooks.Add ' Add a new workbook
    xlWB.SaveAs filename ' Save the new workbook as "filename"
    Set xlWB = xl.Workbooks.Open(filename)  '<--Your Excel File Here
     
     
    xl.Visible = True
    SheetNum = 1
    Do While recordtotal > 0
        rs.Open strSelect, cn, 2, 2
        If rs.EOF Then Exit Sub
        rs.MoveFirst
            Set sht = Nothing
            On Error Resume Next
            Set sht = xlWB.Worksheets("Sheet" & SheetNum)
            On Error GoTo 0
            
            If sht Is Nothing Then
            xlWB.Worksheets.Add After:=Worksheets(Worksheets.count)
                Set sht = ActiveSheet
                sht.Name = "Sheet" & SheetNum
            End If
            sht.Range("A1").CopyFromRecordset rs
            Call GenerateTotals(sht, "B;C", "E")                '<---- Call GenerateTotals
            SheetNum = SheetNum + 1
            DoCmd.RunSQL (strDelete)
        rs.Close
        recordtotal = DCount(FieldToCount, TableToCount)
    Loop
     
    xlWB.Close (True)
    xl.Quit
    Set xl = Nothing
 
End Sub
-------------------------------------------
Private Sub GenerateTotals(objWorkSheet, strGroupColumns, strTotalColumns)
    Const FirstRow = 2
    Dim arrGroupColumns, arrTotalColumns, arrGroupColumnValues, arrTotalColumnValues
    Dim lngI, intJ, blnSameGroup
    Dim lngRowCount
    
    ' Store the column letters into arrays for use when referencing the cells of each row
    arrGroupColumns = Split(strGroupColumns, ";")
    arrTotalColumns = Split(strTotalColumns, ";")
    'Resize the Values arrays to store the current group values and Totals
    ReDim arrGroupColumnValues(UBound(arrGroupColumns))
    ReDim arrTotalColumnValues(UBound(arrTotalColumns))
    
    ' Start at 2nd row to ignore row headings
    lngRowCount = objWorkSheet.UsedRange.Rows.count
    lngI = FirstRow
    While lngI <= lngRowCount
        ' Determine if the Current row grouping values match the previous row grouping values
        'Default the same group variable to be true
        blnSameGroup = True
        For intJ = 0 To UBound(arrGroupColumns)
            blnSameGroup = blnSameGroup And (arrGroupColumnValues(intJ) = objWorkSheet.Range(arrGroupColumns(intJ) & lngI).Value)
            If Not blnSameGroup Then
                Exit For
            End If
        Next
        
        If blnSameGroup Then
            For intJ = 0 To UBound(arrTotalColumns)
                arrTotalColumnValues(intJ) = arrTotalColumnValues(intJ) + objWorkSheet.Range(arrTotalColumns(intJ) & lngI).Value
            Next
        Else
            ' Don't attempt to add a sub totals row if this is the first row
            If lngI > FirstRow Then
                ' Insert a new row above the current row number for inserting the subtotals
                objWorkSheet.Rows(lngI & ":" & lngI).Insert (xlDown)
                
                ' Write out the Sub Totals row, and then reset the grouping values and totals for the new group
                objWorkSheet.Range("A" & lngI).Value = "Sub Total:"
                For intJ = 0 To UBound(arrTotalColumns)
                    objWorkSheet.Range(arrTotalColumns(intJ) & lngI).Value = arrTotalColumnValues(intJ)
                Next
                
                ' increment the row counter so that it is now pointing to the row below the totals
                lngI = lngI + 1
                lngRowCount = lngRowCount + 1
            End If
                        
            ' Assign the new group values to the group values array
            For intJ = 0 To UBound(arrGroupColumns)
                arrGroupColumnValues(intJ) = objWorkSheet.Range(arrGroupColumns(intJ) & lngI).Value
            Next
            ' Assign the new group totals to the group totals array
            For intJ = 0 To UBound(arrTotalColumns)
                arrTotalColumnValues(intJ) = objWorkSheet.Range(arrTotalColumns(intJ) & lngI).Value
            Next
        End If
        lngI = lngI + 1
    Wend
    ' Once we get to the end of the used range, add a row that contains the final sub totals for that page
'    objWorkSheet.Range("A" & lngI).Value = "Sub Total:"
'    For intJ = 0 To UBound(arrTotalColumns)
'        objWorkSheet.Range(arrTotalColumns(intJ) & lngI).Value = arrTotalColumnValues(intJ)
'    Next
End Sub
[+][-]06.01.2008 at 03:31PM PDT, ID: 21688603

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]06.01.2008 at 03:45PM PDT, ID: 21688654

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]06.01.2008 at 03:47PM PDT, ID: 21688662

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]06.01.2008 at 03:51PM PDT, ID: 21688676

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]06.01.2008 at 03:55PM PDT, ID: 21688685

View this solution now by starting your 7-day free trial. Setting up your free trial is quick, easy, and secure. We will return you to this solution, unlocked, when you're done.

 

About this solution

Zones: Microsoft ADP, Microsoft Excel Spreadsheet Software, Access Coding/Macros
Sign Up Now!
Solution Provided By: zorvek
Participating Experts: 1
Solution Grade: A
 
 
 
Loading Advertisement...
20080716-EE-VQP-32 / EE_QW_2_20070628