VBA Runtime Error 1004 "Application-defined or Object-defined error"

I have code VBA code written in MS Access 2010 (.mbd file) to write data into an Excel file (.xls file). Below is the code to write data into that excel file. When you run this code, it always throws Error#1004 "Application-defined or Object-defined
error". When you debug the code (F8) or run it (F5), it runs absolutely fine with out any issues. I am still not able to figure it out on what exactly the issue is. This code works fine when executed in MS Access 2007.
Below is thr code that's getting executed and when it fails, the focus is set on the 3rd last line of the code marked in double astriek mark.
Sub PopulateReport(appExcel As Object, testcam)
Dim Site As String, intRec As Integer, i As Integer, cnt As Integer, intRecSet As Integer, cntr As Integer
Dim F1 As String, F2 As String, F3 As String, F4 As String, F5 As String, F6 As String, F7 As String
Dim F8 As String, F9 As String, F10 As String, F11 As String, F12 As String, F13 As String, CAMDate As Date
Close
i = 0
cnt = 0
cntr = 0
Set cnn = CurrentProject.Connection
rec.Open "SELECT * FROM Site", cnn, adOpenStatic, adLockPessimistic
rec.MoveLast
rec.MoveFirst
intRec = rec.RecordCount
Do Until cnt = intRec
rec.MoveLast
rec.MoveFirst
rec.Move cnt
Site = rec(4)
Select Case Site
Case "Fort Worth"
cntr = 0
recset.Open "SELECT * FROM Employee", cnn, adOpenStatic, adLockPessimistic
recset.MoveLast
recset.MoveFirst
intRecSet = recset.RecordCount
appExcel.Application.Goto Reference:="START_FW_CL"
Do Until cntr = intRecSet - 1
appExcel.Selection.EntireRow.Copy
appExcel.Selection.EntireRow.Insert
cntr = cntr + 1
Loop
appExcel.Application.CutCopyMode = False
appExcel.Application.Goto Reference:="START_FW2_CL"
go = appExcel.Application.Range("START_FW2_CL")
cntr = 1
With appExcel.Worksheets("Accts. > Clearing").[START_FW2_CL]
Do Until recset.EOF
**.Offset(cntr, 0) = recset(0)**
.Offset(cntr, 1) = recset(1)
.Offset(cntr, 2) = recset(2)
End Sub

What's wrong about it? It can only copy what you chose to have in the recordset. If you only want some fields or fields in a different order, replace
SELECT * FROM  with
SELECT Field1, Field2, etc
CopyFromRecordset is bay far the best method and runs much faster.
Rod Gill
Author of the one and only Project VBA Book
www.project-systems.co.nz

Similar Messages

  • Run-time error '1004' Application-Defined or object-defined error

    Hello friends,
    My requirement is to make the cells under Columns Actual, forecast and target (Dimesnion Category) Locked.
    I've used various methods like GetOnlyRange but it didnt work.
    Now, i've selected all the cells of the sheet, where user can input and made them unlocked. ( from Right-click>FormatCells>Protection tab-->Locked checkbox unchecked)
    Then, go to "review" tab, click "Allow Users to edit Ranges",-> Protect Sheet---> ticked "Unlocked Cells"
    Then go to WorkBook Options and set a password for the worksheet.
    But on expand, I'm facing Run-time error '1004' Application-Defined or object-defined error.
    Please help.
    Please help.

    Hi,
    I think that  is VBA Runtime error, you can fix these errors by downloading in various sites.
    http://www.articlesbase.com/data-recovery-articles/vba-runtime-error-1004-application-defined-or-object-defined-error-fix-these-errors--1339060.html
    You can try with the above link.  I hope this could solve your problem.
    Regards,
    B.S.RAGHU

  • Runtime Error 1101. Application-defined or object-defined error

    I am updating VBA code from MS project 2003 plans  to 2013, and have come up with the following error message. 
    Run-time error 1101: Application-defined or object-defined error.
    Any help to remedy the situation would be greatly appreciated.
    Thanks

    jfrh,
    Normally you shouldn't have to make any changes to VBA written under Project 2003 in order for it to work with later versions however sometimes certain statements may need some "tweaking".
    The general description of the run-time error doesn't help us much unless we know a little bit more about your macro. We don't necessarily need to see the whole macro but we do need some context as a starting point. What is the macro supposed to do generally?
    Which line of code is highlighted when the error occurs?
    John

  • Application-defined or Object-defined error

    Hello,
    When I open Input schedule through open dynamic templates I get the following error message
    Application-defined or Object-defined error
    Version : BPC 7.0
    SP05
    Request your guidance.
    Thanks,
    Ramsiva

    I have experienced much the same problem which I have documented in details here:
    Excel Spreadsheet being opened in preview mode by some machines
    (Note that I am only surmising the preview mode is the problem as I get the exact same error if I open it on the Development machine in preview mode).
    My only workaround at the moment is to open the spreadsheet on the target machine and then replace the vba code and save the file locally (Copy Paste), or apply a digital certificate to the existing VBA code, although the latter only seems to work sometimes.
    If I fix the problem on the target machine and then copy, open and close the file on the development machine when the file is sent back to the target machine the problem occurs again.
    I have ruled out emailing being the problem as I have copied the file instead of emailing. 
    The development machine had a number of Office applications and Windows 7 updates applied around the time that the problem occurred, i.e. one day everything is fine, the next day it is impossible to run a new spreadsheet on certain machines.
    The highlighted error is also with a .select statement but I isolated the code and put it into a test spreadsheet and that ran okay so it seems to be a more subtle problem.
    It doesn't happen on all the machines and I can't see any pattern as to what machines it works on and those it doesn't. They are mostly Windows 7 64bit running Office 2010 and 2013, seems to be about 50/50 split as to working and not working. 
    I've ensured that the Windows Updates are up to date on all the problem machines.
    I think it is the same problem and it helps knowing that someone else has experienced the same thing in order that I don't think I'm going crazy but it's a major problem for me and none of the suggestions so far seem to be close to explaining what is going
    on.
    If anyone wants samples in order to investigate the problem I am more than happy to send them the spreadsheets. 

  • Run-time error '1004' -- Method 'Container' of object '_Workbook' failed

    Dear All,
    One of our users is getting the following Microsoft Visual Basic error while running the report S_ALR_87013614.
    Run-time error '1004'
    Method 'Container' of object '_Workbook' failed.
    I have searched the forum posts for help. But I only found some details related to Run-time error 1004 related to some excel file security but not related to "Method 'Container' of object '_Workbook' failed".
    Could anyone please tell me how this error can be eliminated for the user?
    Regards,
    Lakshmi.

    Dear Arpan,
    We too observed a few PIDs along with the one that you have mentioned but they make no difference. Some users who has the PID G_RW_DOCUMENT_TYPE set with some value are getting the report.
    Upon further searching we are assuming that it could be an issue with the Microsoft applications or macro settings of the user. But not sure about it.
    Regards,
    Lakshmi Venigala.

  • " Enter valid code [IGE1.tem code][line1036] application-defined or object defined error65171 "

    Hello All,
    I tried to Import Goods Issue in SAP B1, but I got Error as  below
    “ Enter valid code [IGE1.tem code][line1036] application-defined or object defined error65171 “
    Anyone please suggest me what would be the cause of this error.
    Regards,
    Hitul

    Hi,
    1. Make sure correct item code entered at row level.
    2. Please refer SAP note 3.2 for solution.
    865191
    - Data Transfer Workbench (DTW) Troubleshooting Guide
    3. Are you importing more than 1000 rows?
    Thanks & Regards,
    Nagarajan

  • "Illegals parent number Application-defined or object defined error65171"

    HI Experts,
    I am trying to import a Chart of Account for a new company and I get this error message "Illegals parent number Application-defined or object defined error65171"
    I have seen a couple of post  on this topic but I can't pick out the exact thing I'm doing wrong. Can anybody please put me through?
    If you can give me an email addres I can send the csv for so you can take a look, it format gets disrupted when I paste it here.
    Waiting to Hear from you.
    Regards

    Dear,
    For your issue, If you are using non-segmentation account, please kindly check whether your
    fatherAccountKey is empty or not, this column is mandatory field for non-segmentation account.
    If you are trying to update chart of account with segmentation, please check the note 942939 below:
    Symptom
    When you try to update chart of account with segmentation, using the
    standard template of DTW 2005, you will receive the error message
    "Cannot find this object in B1 Application-defined or object - defined
    error 65171.
    Other terms
    DTW; update; chart of account; SAP Business One;
    Reason and Prerequisites
    Possible reason:
    1, Field     'Code' is blank.
    In DI API Help file 2005 for OChartofAccount, it says that Field "Code"
    is the Mandatory field in SAP Business One when Not Working with
    Segmentation.
    2, Field     'FormatCode'
    The Account Segment Separator '-'.existed in 'FormatCode' field.
    Solution
    1, Field     'Code' is blank.
    For updating existing chart of account with segmentation, This field is
    mandatory. You must fill it with the account code of that account you
    want to update. You can get the code of each account #_SYS00000000XX#
    from OACT table. Otherwise, we cannot update it.
    It is not covered in DI API Help file 2005.
    2, Field     'FormatCode'
    Please delete the Account Segment Separator '-'. For example, change
    11005-000-00-11 to 110050000011. System will identify automatically.
    Please make sure that the field is a Text format cell. You can change
    the format cell by right click the cell.
    Wish the information above could solve your issue.
    Regards
    Apple

  • DTW - COA error Illegal parent numberApplication-defined or object-defined

    Hi friends,
    I am getting error "Illegal parent numberApplication-defined or object-defined errorchartOfAccounts"
    while executing DTW - COA.
    I am using country India verson and new company is created with user defined COA option.
    I have used 100000000000000 to 500000000000000 as parent code for 2nd level accounts as the same is standard drawers for Country India version Chart of Account at level 1.
    Can anybody throw some light on this ?
    Thanks,
    Samir Gandhi
    Edited by: Samir Gandhi on Oct 15, 2008 11:51 AM

    Suda,
    Below find the sample in code tag.
    Code     AccountType     AcctCurrency     ActiveAccount     AllowChangeVatGroup     BudgetAccount     CashAccount     DataExportCode     DefaultVatGroup     Details     ExternalCode     FatherAccountKey     ForeignName     FormatCode     LiableForAdvances     LockManualTransaction     Name     ProjectCode     Protected     RateConversion     ReconciledAccount     RevaluationCoordinated     TaxExemptAccount     TaxLiableAccount
    Code     AccountType     AcctCurrency     ActiveAccount     AllowChangeVatGroup     BudgetAccount     CashAccount     DataExportCode     DefaultVatGroup     Details     ExternalCode     FatherAccountKey     ForeignName     FormatCode     LiableForAdvances     LockManualTransaction     Name     ProjectCode     Protected     RateConversion     ReconciledAccount     RevaluationCoordinated     TaxExemptAccount     TaxLiableAccount
                   tNO     tNO     tNO                              100000000000000          10000000          tNO     ASSETS          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10000000          10100000          tNO     Fixed Assets          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10100000          10101000          tNO     Fixed Assets-Tangible          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101100          tNO     Free Hold Land          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101100          10101101          tNO     Free Hold Land          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101200          tNO     Lease Hold Land          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101200          10101201          tNO     Lease Hold Land          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101300          tNO     Factory Building          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101300          10101301          tNO     Factory Building          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101400          tNO     Non-Factory Building          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101400          10101401          tNO     Non-Factory Building          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101500          tNO     Plant & Machinery          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101500          10101501          tNO     Plant & Machinery          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101600          tNO     Electric Supply System          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101600          10101601          tNO     Electric Supply System          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101700          tNO     Vehicles          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101700          10101701          tNO     Vehicles          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101800          tNO     Furniture & Fittings          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101800          10101801          tNO     Furniture & Fittings          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10101000          10101900          tNO     Office Equipments          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10101900          10101901          tNO     Office Equipments          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10100000          10102000          tNO     Fixed Assets-InTangible          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10102000          10102100          tNO     "Concessions,Patents,Licences,Trademarks,etc."          tNO     tNO     tNO     tNO     tNO     tNO
         at_Other     INR     tYES     tNO     tNO                              10102100          10102101          tNO     Trade Marks          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10102000          10102200          tNO     Goodwill          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10100000          10200000          tNO     Accumulated Depreciation - Tangible Assets          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10200000          10201100          tNO     Free Hold Land          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10200000          10201200          tNO     Lease Hold Land          tNO     tNO     tNO     tNO     tNO     tNO
                   tNO     tNO     tNO                              10200000          10201300          tNO     Factory Building          tNO     tNO     tNO     tNO     tNO     tNO
    Thanks,
    Samir Gandhi

  • Runtime Error '1004':, Method 'Intersect' of object '_Global' failed

    Hello
    I am getting a runtime error 1004, can someone tell me why?  I am getting the runtime error on the first Application.Intercept statement.
    Thank you for your help!
    smsemail
    Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    If Not Application.Intersect(Target, Me.Range("A:A")) Is Nothing Then
    lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    If lastRow < 17 Then
    Exit Sub
    End If
    If lastRow > 67 Then
    lastRow = 67
    End If
    Else
    Exit Sub
    End If
    If Not Application.Intersect(Target, Me.Range("A17:A" & lastRow)) Is Nothing Then
    Application.EnableEvents = False
    If Application.WorksheetFunction.CountA(Worksheets("RIPS").Range("A17:A67")) = 0 Then
    Exit Sub
    End If
    If Application.WorksheetFunction.CountA(Worksheets("RIPS").Range("B17:B67")) = 0 And _
    Application.WorksheetFunction.CountA(Worksheets("RIPS").Range("C17:C67")) = 0 And _
    Application.WorksheetFunction.CountA(Worksheets("RIPS").Range("D17:D67")) = 0 Then
    Exit Sub
    End If
    If CmdExecute = True Then
    Exit Sub
    End If
    If CmdClear = True Then
    Exit Sub
    End If
    Worksheets("RIPSSummary").Activate
    lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    Set SourceRange = Application.Intersect(Range("A2:A" & lastRow), ActiveSheet.UsedRange)
    MsgBox "Source Range: " & SourceRange
    Worksheets("RIPS").Activate
    lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    Set TargetRange = Application.Intersect(Range("A17:A" & lastRow), ActiveSheet.UsedRange)
    MsgBox "Target Range: " & TargetRange
    Exit Sub
    wsDeleted = False
    For Each acell In SourceRange.Cells
    RecordFound = True
    If Not IsEmpty(acell.Value) Then
    Set C = TargetRange.Find(acell.Value, LookIn:=x1values)
    If C Is Nothing Then
    RecordFound = False
    End If
    If RecordFound = False Then
    wsDeleted = True
    For Each Worksheet In Worksheets
    If Worksheet.Name = acell.Value Then
    Worksheet.Delete
    End If
    Next Worksheet
    End If
    End If
    Next acell
    If vbKeyDelete Or _
    vbKeyClear Then
    r = lastRow
    Do Until r < 17
    If Worksheets("RIPS").Range("A" & r).Value = "" Then
    Rows(r).Delete
    End If
    r = r - 1
    Loop
    End If
    Application.EnableEvents = True
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub

    It should work but maybe there's something about your workbook we can't see.
    In passing generally best not to disable screenupdating, alerts or events unless need to do so. More importantly though you should ensure they always get reset. As written you have several Exit Sub's before any code that resets them. Also in case of an error
    consider resetting them in an error handler.

  • When I click on firefox to open in my Mac, an error shows up: plug-in object Type error: id is undefined. When I click on the OK button, firefox opens. This never happened in FF 3. What is this?

    Also when I am in a site, such as an account, and click on a highlighted link, I get another error, {Javascript Application] can't create mcafee plug-in object: Type Error: components. classes [cid] is undefined. The only mcafee I had on my computer was the secure search and I uninstalled it, but I still get this message. When I click on the OK button with the error message, then the link opens up.

    Start Firefox in [[Safe Mode]] to check if one of the add-ons is causing the problem (switch to the DEFAULT theme: Tools > Add-ons > Appearance/Themes).
    * Don't make any changes on the Safe mode start window.
    See:
    * [[Troubleshooting extensions and themes]]

  • Excel Application-defined or object-defined error 32809

    This error occurs on files that are received from outside our company network.
    A file created on our company network, sent to customers (a technical questionnaire) who then complete and return them, no longer works correctly. This occurs when the file is sent by email or on a USB drive and is opened and then saved, even with no changes.
    The Excel version is 2010 32 bit on Win8 64 bit machines
    The error triggers in many different VBA sub routines on lines such as Sheets("Home").Select, and on lines in the immediate window such as Print Activesheet.name

    I have experienced much the same problem which I have documented in details here:
    Excel Spreadsheet being opened in preview mode by some machines
    (Note that I am only surmising the preview mode is the problem as I get the exact same error if I open it on the Development machine in preview mode).
    My only workaround at the moment is to open the spreadsheet on the target machine and then replace the vba code and save the file locally (Copy Paste), or apply a digital certificate to the existing VBA code, although the latter only seems to work sometimes.
    If I fix the problem on the target machine and then copy, open and close the file on the development machine when the file is sent back to the target machine the problem occurs again.
    I have ruled out emailing being the problem as I have copied the file instead of emailing. 
    The development machine had a number of Office applications and Windows 7 updates applied around the time that the problem occurred, i.e. one day everything is fine, the next day it is impossible to run a new spreadsheet on certain machines.
    The highlighted error is also with a .select statement but I isolated the code and put it into a test spreadsheet and that ran okay so it seems to be a more subtle problem.
    It doesn't happen on all the machines and I can't see any pattern as to what machines it works on and those it doesn't. They are mostly Windows 7 64bit running Office 2010 and 2013, seems to be about 50/50 split as to working and not working. 
    I've ensured that the Windows Updates are up to date on all the problem machines.
    I think it is the same problem and it helps knowing that someone else has experienced the same thing in order that I don't think I'm going crazy but it's a major problem for me and none of the suggestions so far seem to be close to explaining what is going
    on.
    If anyone wants samples in order to investigate the problem I am more than happy to send them the spreadsheets. 

  • Cisco CRS Historical Reports error "run time error 364 application defined or object-defined error"

    Hi All,
    we are getting an error when we open historical report

    Hi;
    The 713 error generally means something is not installed correctly for the runtime.
    How did you deploy the runtime to the client system?
    Regards,
    Jonathan

  • Err: Non-valid period-application  defined or  object defined error orders

    Hi
    Please solve above error
    When importing the Sales Order Data i got this error.
    I don't  undertstand yet this error
    Please help  me
    Kishor

    kishor,
    Please help us, help you.
    You have to provide more information in order for us to understand the problem.
    Where were you? (indicate what module and form you were working in).
    What were you doing? (please state every step you made in the form).
    What was the complete error message?
    Best Regards,
    Vítor

  • Runtime error 32809 Application or object defined

    My code is used by six different remote sites [exact same code]. I made some changes to the code, export the changed modules to a file which is then imported in the various site's program. Before I sent the code to the user I run a test to ensure there's
    no problems. I've being doing this for some time without any hazels. No suddenly I get this message on some of the sites at different areas of the code. For instance this is some part of my code:
    If ActiveSheet.name = "ABC" then tSer [public decl as long] = 5
    If ActiveSheet.name = "DEF" then tSer = 6
    If ActiveSheet.name = "GHI" then tSer  = 7
    I get the error on the first line [ABC]. My limited VBA knowledge tells me even if sheet ABC does not exits, the code should   do the next test?
    Any assistance would be much appreciated! I search for error code 32809 - No results.
    Tank you

    Hello Hennie,
    The
    Excel Application-defined or object-defined error 32809 forum thread states the following:
    Many users have run into this problem recently. This could be caused by an update for the Office application. Please take a look at this thread:
    https://social.technet.microsoft.com/Forums/en-US/473b1980-56b3-49ff-be71-3a60c0db048b/form-controls-stop-working-after-december-2014-updates?forum=excel
    There's a probabability that the customers outside the corperate network had installed the update, so when they opened the workbook you created, it damage the workbook. Please try the solutions provided in the thread.
    Also some users work around by adding some inconsequential comments after the Select method, or create a brand new workbook then copy the data and VBA code in it. 

  • Runtime Error 1004

    I have a workbook with VBA and I am getting a 'Run-time Error 1004' and when I hit the debug the process stops at below lines of codes:
    ' Insert blank rows, one to hold each period and one for the total line
        With resultArea.Cells(RowNum, KeyFigCol - 1)  {it says Application defined or Object defined error}
        If .Value <> "" Then
    I saw other threads for this error and I checked the OSS-429183. Also my macro>>security is set to low.
    Any suggestions? Plus I am getting this error only in dev environment, stage & production work fine. I have verified the VBA code and they all have same code.

    Hi All, I still have this problem. I have the same VBA code in all the systems, but it gets error in development system only. its working fine in other systems. That's what breaks my head:(
    Any suggestions. I have attached my VBA code.
    '* Variable Declarations
      Dim Column As Integer
      Dim StrPos As Long
      Dim TempStr As String
      Dim RowNum As Integer
      Dim StrRowNum As Integer
      Dim EndRowNum As Integer
      Dim EndColNum As Integer
      Dim KeyFigCol As Integer
      Dim DelStrCol As Integer
      Dim LabelPos As Integer
      Dim ActiveCellSave As String
      Dim MonthFlag As String
      Dim MonthFlagPrev As String
      Dim MonthColStr As Integer
      Dim MonthColEnd As Integer
      Dim MonthCol1st As Integer
      Dim MatMonRow As Integer
      Dim ColPrjAvl As Integer
      Dim ColTopGrn As Integer
      Dim ColTopYel As Integer
      Dim ColTopRed As Integer
      Dim ColRmdRpl As Integer                   '001A
      Dim ColMaxQty As Integer
      Dim ColRplQty As Integer
      Dim First As Boolean
      Dim NumPeriods As Integer                  '001A
      Dim UsgPerDay As Integer                   '001A
      Dim StartTime
      Dim EndTime
    ' Check the query id to determine which sheet to activate
    If queryID = "SAPBEXq0016" Then      'Monthly Query
      'Application.ScreenUpdating = False
    'Set sheet "Inventory Montly Analysis" to active
      Sheets(3).Activate
      NumPeriods = 13                              '001A
    '* 001A: Set "Inventory Weekly Analysis" to active
    ElseIf queryID = "SAPBEXq0018" Then  ' Weekly query
      Sheets(4).Activate
      NumPeriods = 24
    '* 001A: Set "Inventory Replenishment" to active
    ElseIf queryID = "SAPBEXq0017" Then  ' Replenishment Detail query
      Sheets(6).Activate
      NumPeriods = 0
    Else
      Exit Sub
    End If
    '* 001A: End of new code
    '* Initialization Routines
      First = True
    ' For performance testing, save off the start time of the macro
      StartTime = Time
    ' Save off the current cell location so that we can restore that location
    ' when formatting is compelte
      ActiveCellSave = ActiveCell.Address()
      If ActiveCell.Value <> "No applicable data found." Then
    ' Determine the First Row in the spreadsheet where query results are displayed
    ' The first row will be stored in variable RowNum
      TempStr = resultArea.Address(RowAbsolute:=False, ColumnAbsolute:=False)
      StrRowNum = 0
      Do While StrRowNum = 0
        StrRowNum = Val(TempStr)
        If StrRowNum = 0 Then
          TempStr = Mid(TempStr, 2, 20)
        End If
        If TempStr = "" Then
          Exit Do
        End If
      Loop
    ' Determine the Last Row in the spreadsheet where query results are displayed
    ' The last row will be stored in variable EndRowNum
      TempStr = resultArea.Address(RowAbsolute:=False, ColumnAbsolute:=False)
      StrPos = InStr(TempStr, ":")
      TempStr = Right(TempStr, Len(TempStr) - StrPos)
      EndRowNum = 0
      Do While EndRowNum = 0
        EndRowNum = Val(TempStr)
        If EndRowNum = 0 Then
          TempStr = Mid(TempStr, 2, 20)
        End If
        If TempStr = "" Then
          Exit Do
        End If
      Loop
    ' Determine the Last Column in the spreadsheet where query results are displayed
    ' The last column number will be stored in EndColNum
      TempStr = resultArea.Address(RowAbsolute:=False, ColumnAbsolute:=False, ReferenceStyle:=xlR1C1)
      StrPos = InStr(TempStr, ":")
      If StrPos > 0 Then
        TempStr = Right(TempStr, Len(TempStr) - StrPos)
        StrPos = InStr(TempStr, "C")
        If StrPos = 0 Then
          EndColNum = 255
        Else
          TempStr = Right(TempStr, Len(TempStr) - StrPos - 1)
          EndColNum = Val(TempStr)
        End If
      End If
    ' Clear all of the old contents below the query result area
      TempStr = Format(EndRowNum + 1) + ":" + Format(65536)
      ActiveSheet.Rows(TempStr).Select
      Selection.Clear
    ' Determine the location of various key figure columns needed in subsequent processing
      KeyFigCol = 0
      For Column = 1 To EndColNum
    ' Find the start column for the key figures - Indicated by the first column
    ' with a dash "-" character in it.
        If InStr(resultArea.Cells(1, Column).Value, " - ") <> 0 Then
          If KeyFigCol = 0 Then KeyFigCol = Column
        End If
    ' Find the Projected Available Column
        If (ColPrjAvl = 0) And (InStr(resultArea.Cells(1, Column).Value, "Proj") <> 0) Then
          ColPrjAvl = Column
        End If
    ' Find the Top of Green Column
        If (ColTopGrn = 0) And (InStr(resultArea.Cells(1, Column).Value, "Top of Green") <> 0) Then
          ColTopGrn = Column
        End If
    ' Find the Top of Yellow Column
        If (ColTopYel = 0) And (InStr(resultArea.Cells(1, Column).Value, "Top of Yellow") <> 0) Then
          ColTopYel = Column
        End If
    ' Find the Top of Red Column
        If (ColTopRed = 0) And (InStr(resultArea.Cells(1, Column).Value, "Top of Red") <> 0) Then
          ColTopRed = Column
        End If
    ' Find the Recommended Replenishment Quantity
        If (ColRmdRpl = 0) And (InStr(resultArea.Cells(1, Column).Value, "Recommended Replenishment Qty") <> 0) Then
          ColRmdRpl = Column
        End If
    ' Find the Usage Per Day
        If (UsgPerDay = 0) And (InStr(resultArea.Cells(1, Column).Value, "Usage Per") <> 0) Then
          UsgPerDay = Column
        End If
    ' Find the Maximum Order Column
        If (ColMaxQty = 0) And (InStr(resultArea.Cells(1, Column).Value, "Maximum Order Quantity") <> 0) Then
          ColMaxQty = Column
        End If
    ' Find the Recommended Replenishment Column
        If (ColRplQty = 0) And (InStr(resultArea.Cells(1, Column).Value, "Recommended Replenishment") <> 0) Then
          ColRplQty = Column
        End If
      Next Column
    '* Begin of main formatting loop
    '* Logic for Recommended Repl Highlighting
      If NumPeriods = 0 Then
    ' Highlight the Recommended Replenishment Quantity
        For RowNum = 2 To EndRowNum
          If resultArea.Cells(RowNum, ColRplQty).Value > resultArea.Cells(RowNum, ColMaxQty).Value Then
               resultArea.Cells(RowNum, ColRplQty).Interior.ColorIndex = 7  'Highlight Red
          End If
        Next RowNum
    '* Logic for Monthly and Weekly Queries
      Else
    ' Work from the bottom up, inserting new lines and folding the keyfigures
    ' downward into one row for each month
      For RowNum = EndRowNum To 2 Step -1
    ' Insert blank rows, one to hold each period and one for the total line
        With resultArea.Cells(RowNum, KeyFigCol - 1)  This is where it stops & gives Runtime Error 1004
        If .Value <> "" Then
    ' For the bottom-most characteristic row, we must cut and paste differently to ensure
    ' the cells formats are properly pasted in the new rows
        If First Then
          TempStr = Format(RowNum) + ":" + Format(RowNum + NumPeriods)
          resultArea.Rows(TempStr).Select
          Selection.Insert Shift:=xlDown
          resultArea.Rows(RowNum + NumPeriods + 1).Select
          Selection.Cut
          resultArea.Rows(RowNum).Select
          ActiveSheet.Paste
          First = False
    ' If this is the first characteristic record, and it resides in row 2, then we know that the
    ' query only has one row of data - special formatting is required in this situation
          If RowNum = 2 Then
            resultArea.Cells(2, 1).Select
            Selection.Copy
            Range(ActiveSheet.Cells(StrRowNum + 2, 1), ActiveSheet.Cells(EndRowNum + NumPeriods, KeyFigCol - 1)).Select
            Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                                   False, Transpose:=False
          End If
    ' Not the first row, use normal processing
        Else
          TempStr = Format(RowNum + 1) + ":" + Format(RowNum + NumPeriods)
          resultArea.Rows(TempStr).Select
          Selection.Insert Shift:=xlDown
        End If
    ' As we insert rows for each characteristic row, we need to adjust the end row
    ' number accordingly
        EndRowNum = EndRowNum + NumPeriods
    ' Initialize variables used for each set of month processing
        MatMonRow = RowNum + 1
        MonthFlagPrev = ""
        MonthFlag = ""
        MonthColStr = 0
    ' Scan key figure column headings from left to right, looking for changes in month
        For i = KeyFigCol To EndColNum + 1
    ' Get the month text for each column
          MonthFlag = ""
          TempStr = resultArea.Cells(1, i).Value
          MonthFlag = Mid(TempStr, InStr(TempStr, "-") + 1, 15)
    ' If we move into a new month, then copy and paste the previous month downward
          If ((MonthFlag <> MonthFlagPrev) And (MonthFlagPrev <> "")) Or (i = EndColNum + 1) Then
            If DelStrCol = 0 Then DelStrCol = i + 1     ' Capture last key figure of first month
            If i = EndColNum + 1 Then i = i + 1         'For results row, need to extend by one
    ' Copy and paste values for previous month
            Range(resultArea.Cells(RowNum, MonthColStr), resultArea.Cells(RowNum, i - 1)).Select
            Selection.Copy
            resultArea.Cells(MatMonRow, MonthCol1st).Select
            ActiveSheet.Paste
    ' Paste the Month text into the row heading
            resultArea.Cells(MatMonRow, MonthCol1st - 1).Value = MonthFlagPrev
            If MonthFlagPrev = " Average Result" Then
              Range(resultArea.Cells(MatMonRow, MonthCol1st - 1), resultArea.Cells(MatMonRow, EndColNum)).Select
              Selection.Interior.ColorIndex = 36
            End If
            With resultArea.Cells(MatMonRow, ColPrjAvl)
            If .Value >= resultArea.Cells(RowNum, ColTopGrn).Value Then
               .Interior.ColorIndex = 43   'Green Green
            ElseIf .Value >= resultArea.Cells(RowNum, ColTopYel).Value Then
               .Interior.ColorIndex = 14   'Green
            ElseIf .Value >= resultArea.Cells(RowNum, ColTopRed).Value Then
               .Interior.ColorIndex = 44   'Yellow
             Else
               .Interior.ColorIndex = 7  'Red
            End If
            End With
            MonthColStr = i
            MatMonRow = MatMonRow + 1
          End If
    ' Set variables on first pass through
          If MonthColStr = 0 Then
            MonthColStr = i
            MonthCol1st = i
            MonthFlagPrev = MonthFlag
          End If
    ' Capture the previous month text
          If MonthFlagPrev <> "" Then
            MonthFlagPrev = MonthFlag
          End If
        Next i
    ' Clear out the key figure data at the lowest characteristic level
        Range(resultArea.Cells(RowNum, KeyFigCol), resultArea.Cells(RowNum, EndColNum)).Select
        Selection.ClearContents
        End If
        End With
        Next RowNum
    ' Strip out the month text from column headings
        For i = KeyFigCol To DelStrCol
        LabelPos = InStr(resultArea.Cells(1, i).Value, "-")
          If LabelPos > 1 Then resultArea.Cells(1, i).Value = _
                               Left(resultArea.Cells(1, i).Value, LabelPos - 1)
        Next i
    ' Remove Extraneous columns (months 2-12)
        Range(resultArea.Cells(1, DelStrCol - 1), resultArea.Cells(EndRowNum, EndColNum + 1)).Select
        Selection.Clear
    ' Format Column Headings with appropriate column widths and heights
        resultArea.Rows(1).Select
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 1
            .ShrinkToFit = False
            .MergeCells = False
            .RowHeight = 31.5
        End With
    ' 001A: Add empty cells for Recommended replenishment
            If ColRmdRpl <> 0 Then
              For i = 2 To EndRowNum
                If resultArea.Cells(i - 1, 1) = "" Then
                  Range(resultArea.Cells(i, ColRmdRpl), resultArea.Cells(i, ColRmdRpl + 4)).Insert Shift:=xlToRight
                End If
              Next i
              Columns(ColRmdRpl + 5).Copy
              Range(Columns(ColRmdRpl), Columns(ColRmdRpl + 4)).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False
              Application.CutCopyMode = False                     
            If UsgPerDay <> 0 Then
              For i = 2 To EndRowNum
                If resultArea.Cells(i - 1, 1) = "" Then
                   resultArea.Cells(i, UsgPerDay).Insert Shift:=xlToRight
                End If
              Next i
              Columns(ColRmdRpl + 5).Copy
              Range(Columns(ColRmdRpl), Columns(ColRmdRpl + 4)).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=False
              Application.CutCopyMode = False
            End If
            For i = 3 To EndRowNum
              If resultArea.Cells(i - 1, 1) <> "" Then
                 Range(resultArea.Cells(i, ColRmdRpl + 1), resultArea.Cells(i + NumPeriods - 1, ColRmdRpl + 4)).Select
                 Selection.FillDown
                 Range(resultArea.Cells(i, UsgPerDay), resultArea.Cells(i + NumPeriods - 1, UsgPerDay)).Select
                 Selection.FillDown
              End If
            Next i
    ' Remove Extraneous columns (months 2-12)
              Range(resultArea.Cells(1, DelStrCol - 1), resultArea.Cells(EndRowNum, EndColNum + 1)).Select
              Selection.Clear
            End If
    ' 001A: End of new code
        End If
        End If
        Columns("A:BA").ColumnWidth = 10
        resultArea.Columns.AutoFit
    ' Set Zoom level at 75%
        ActiveWindow.Zoom = 75
    ' Restore the active cell
        Range(ActiveCellSave).Select
      '  EndTime = Time
      '  MsgBox StartTime
      '  MsgBox EndTime
    '   StartTime = EndTime - StartTime
    '   MsgBox StartTime
    '   End If
    '  End If 
    'Application.ScreenUpdating = True 
    End Sub

Maybe you are looking for

  • Problem with sound in games requiring quicktime

    I recently purchased CSI 1. I installed the game and the latest version of quicktime player. As soon as the game starts and the first character starts talking the game pauses as if loading and then plays for a second and pauses again for a few second

  • No local string defined -- Inconsistent Module State

    I am trying to deploy an Enterprise Application and during compilation I get the following error. Any idea? I am using Sun Java System Application Server 8.1 and jdk1.5.0_08, javax.enterprise.system.tools.deployment|_ThreadID=14;|Se produjo una excep

  • In premier elements ...how do you render the menu screen?

    I have Premier Elements . Do you render the menu screens for more clarity?

  • Embed Lightroom Slideshow in Activerain Blog

    I've been trying (in vain) to embed a Lightroom slideshow into my activerain blog here: http://activerain.com/blogsview/658980/Homes-Near-Peterson-and The slideshow should be in that big blank white space near the bottom of the post. I'm hosting the

  • Service 'ipod service' Error

    I had recently had to reinstall windows on my computer and I know that I am regretably using older software for installation but before doing so I did have itunes on my computer and now tryin to install it I keep geting the same problem at the point