Vba run code on workbook first open Results

I'd like some code to run the first time someone opens the file. It's an .xltm file (could be .xlsm though).

How do I execute code the first time someone opens the book, but not the second onwards? I have googled and found people using
But I don't understand the code. Is it relevant to my problem? Could someone explain/translate it to English?

I want the code to run a form (simple enough) and also set the file name but NOT actually open the dialogue to save the file.
So when they open the workbook, a form comes up, they enter some details eg. Date and their name and press OK.

Later when they go to save the file, it should do a save as, and the file name should be <name> - <date>.xlsm

Hey everybody

In my workbook, i have about 5 or 6 buttons and a VBA statement linked to 'CTRL+F' (done on purpose to override the excel find function).

However, when i open a second or a 3rd workbook (which is very common) and I press 'CTRL+F' in the 2nd or 3rd workbook, it runs the VBA statement from 1st workbook.

Is there anyway to like house the VBA statement to the one workbook, so when I press 'CTRL+F' in any other workbook, it doesn't run the code from the first?

Cheers in advance



I'm using a simple piece of VBA to temporarily copy a worksheet, order it, print preview it then delete the temporary worksheet.

Other users are set to read only and if they open the workbook first there is no problem, if I open it with full access first then the user opens as read only they receive a runtime error 1004 method of range error on running the macro.

Any ideas? I've included the code below and the error pops up at line 5 "cells.select"

    Application.ScreenUpdating = False 
    Sheets("Manning").Copy Before:=Sheets(1) 
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("g2") _ 
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _ 
    False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _ 
    Selection.Delete Shift:=xlToLeft 
    Selection.Delete Shift:=xlToLeft 
    Sheets("Manning (2)").Select 
    Application.DisplayAlerts = False 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Any ideas appreciated


I have a folder of workbooks. I'm trying to cycle through them and produce graphs for each of the columns, but I keep running into a whole series of frustrating errors and I can't work this one out.

The line I keep having trouble with is:

.Chart.SetSourceData Source:=wbOpen.Worksheets("Data1").Range(wbOpen.Worksheets("Data1").Cells(11, cycleCounter),
wbOpen.Worksheets("Data1").Cells(103, cycleCounter)) 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I get the error:
'Run-time error '-2147467259 (80004005)':
Automation error
Unspecified error

I usually run this from the code screen. At the moment, it stops at the aforementioned line on the first chart of every new file that is opened. If I "Debug" then click on my spreadsheet where the charts are going and then go back to the code, it allows me to continue.

Here's the code:

    Dim wbOpen As Workbook 
    Dim wbNew As Workbook 
     'Change Path
    Dim strPath As String 
    Dim strExtension As String 
    Dim cycleCounter, rowCounter, numColumns, numRows As Integer 
    Dim srcRange, wbName As String 
     'Comment out the 3 lines below to debug
     'Application.ScreenUpdating = False
     'Application.Calculation = xlCalculationManual
     'On Error Resume Next
    strPath = ThisWorkbook.Worksheets("Reference").Range("B1").Value 
    If Right(strPath, 1) = "" Then 
         ' Do nothing
        strPath = strPath & "" 
    End If 
    ChDir strPath 
     'Change extension
    strExtension = Dir("*.xls") 
    Do While strExtension  "" 
        Set wbOpen = Workbooks.Open(strPath & strExtension) 
        wbName = wbOpen.Name 
        numColumns = Application.WorksheetFunction.CountA(wbOpen.Worksheets("Data1").Range("1:1")) 
        ThisWorkbook.ActiveSheet.Name = "Graphs " & wbName 
        For cycleCounter = 2 To numColumns + 1 
            numRows = Application.WorksheetFunction.CountA(wbOpen.Worksheets("Data1").Range("A:A")) 
            With ThisWorkbook.Worksheets("Graphs " & wbName).ChartObjects.Add(Left:=0, Width:=600, Top:=0 + (cycleCounter -
2) * 250, Height:=225) 
                .Chart.SetSourceData Source:=wbOpen.Worksheets("Data1").Range(wbOpen.Worksheets("Data1").Cells(11,
cycleCounter), wbOpen.Worksheets("Data1").Cells(103, cycleCounter)) 
                .Chart.ChartType = xlLine 
                .Chart.HasLegend = False 
                .Chart.HasTitle = True 
                .Chart.ChartTitle.Text = "=[" & wbName & "]Data1!R1C" & cycleCounter 
                .Chart.Axes(xlValue, xlPrimary).HasTitle = True 
                .Chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "=[" & wbName & "]Data1!R2C" & cycleCounter 
                .Chart.SeriesCollection(1).XValues = "=[" & wbName & "]Data1!R11C1:R103C1" 
            End With 
        Next cycleCounter 
        strExtension = Dir 
    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 
    On Error Goto 0 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

I have the below VBA code, I am wondering if there is a way to change the email part that it opens up the persons default mail program because not everyone who uses it will use outlook?

Sub EmailStaticSheet()

'Declare all variables
    Dim olApp As Object, olMail As Object
    Dim wb As Workbook, wbNew As Workbook
    Dim ws As Worksheet, wsTemp As Worksheet, wsNew As Worksheet
    Dim strFullName As Variant
'Check and set variables
    If ActiveWorkbook Is Nothing Then
        MsgBox "You must have an open workbook first!", vbInformation, "ERROR!"
        Exit Sub
    End If
    Set wb = ActiveWorkbook
    Set ws = wb.ActiveSheet
'Set app properties down while running
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
'Create a copy of the active sheet, make values static
    wb.Unprotect Password:="gnd"
    ws.Copy before:=wb.Sheets(1)
    Set wsTemp = wb.Sheets(1)
    wsTemp.Unprotect Password:="gnd"
    wsTemp.UsedRange.PasteSpecial xlPasteValues
'Create a new workbook, move temp sheet to it
    Set wbNew = Workbooks.Add(xlWBATWorksheet)
    wsTemp.Move after:=wbNew.Sheets(1)
'Have user set the save name/path, if cancel is pressed exit without saving new file
    strFullName = Application.GetSaveAsFilename("", "Excel Files (*.xls), *.xls")
    If TypeName(strFullName) = "Boolean" Then
        wbNew.Close False
        MsgBox "Action cancelled!", vbExclamation, "CANCELLED!"
        GoTo ExitNow
    End If
'Save workbook as specified name (will overwrite) and close file
    wbNew.SaveAs strFullName
    wbNew.Close False
'Get Outlook application, check if open first, if not open then open one manually
    'On Error Resume Next
    'Set olApp = GetObject(, "Outlook.Application")
    'If olApp Is Nothing Then
        'Set olApp = CreateObject("Outlook.Application")
    'End If
    'On Error GoTo 0
'Create mail item, attach file, display email
    'Set olMail = olApp.createitem(0)
    'olMail.To = "email address here"
    'olMail.Cc = "email address here"
    'olMail.Subject = "Quote or Contract"
    'olMail.attachments.Add strFullName

'Reset application properties
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

I am a beginner in VBA for excel. I am trying to make a code that works on the workbook open event, and after looping thru a series of 10 worksheets searching for values to copy and paste in another worksheet, the code opens another workbook (with a different name), and loops thru another series of 10 worksheets that have the same name as the above mentioned searching for values to copy and paste in the same worksheet of the first open workbook. When the code tries to open the second workbook, I keep getting the runtime error 1004, error on method Open on workbooks object. Any ideas about this problem?

The code I am running is as follows:

    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
     '  La siguiente seccion del codigo se encarga de activar la hoja2 (Equipos) y _
     '  Protegerla contra escritura, permitiendo la edicion de las celdas no protegidas _
     '  y el uso de agrupar/desagrupar datos.
    Hoja2.Protect Password:="", DrawingObjects:=False, Contents:=True, Scenarios:=False, _ 
    UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _ 
    AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows:=True, _ 
    Hoja2.EnableOutlining = True 
     '  La siguiente seccion del codigo se encarga de verificar la fecha de actualizacion
     '  de los listados de materias primas del archivo actual.
    Dim Contador_LEP As Integer 
    Dim Inicio As Integer 
    Dim Final As Integer 
    Dim Texto As String 
    Inicio = Sheets("Grupos de Recursos").Range("a3") 
    Final = Sheets("Grupos de Recursos").Range("a12") 
    For Contador_LEP = Inicio To Final 
        Texto = Sheets("Grupos de Recursos").Range("b" & 3 + Contador_LEP & "") 
        If Sheets("GR0" & Contador_LEP & " - " & Texto & "").Visible = False Then 
            Sheets("GR0" & Contador_LEP & " - " & Texto & "").Visible = True 
        End If 
        Sheets("GR0" & Contador_LEP & " - " & Texto & "").Select 
        Application.Goto Reference:="EP.Fecha.GR0" & Contador_LEP & "" 
        Sheets("GR0" & Contador_LEP & " - " & Texto & "").Visible = False 
    Next Contador_LEP 
     ' La siguiente parte del codigo verifica cual fue la ultima fecha de actualizacion _
     ' del listado de materias primas del archivo maestro.
    Workbooks.Open "c:fibratorebase de datos principal fibratore.xlsm" 'Here is were I get the error
    For Contador_LEP = 0 To 9 
        Windows("Base de Datos Principal Fibratore.xlsm").Activate 
        Application.Goto Reference:="EP.Fecha.GR0" & Contador_LEP & "" 
        Windows("Laminados de Equipos Principales.xlsm").Activate 
        Application.Goto Reference:="EP.Fecha.GR0" & Contador_LEP & ".VMR" 
    Next Contador_LEP 
    Application.CutCopyMode = False 
    Windows("Base de Datos Principal Fibratore.xlsm").Activate 
    Sheets("Equipos").Outline.ShowLevels Rowlevels:=1 
    Application.Calculation = xlCalculationAutomatic 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The workbook that I try to open when I get the error, also runs a code on the workbook open event. The code it runs is as follows:

    Application.ScreenUpdating = False 
    Dim Contador_BDP As Integer 
    Dim Inicio_BDP As Integer 
    Dim Final_BDP As Integer 
    Dim Texto_BDP As String 
    Inicio_BDP = Sheets("Grupos de Recursos").Range("a3") 
    Final_BDP = Sheets("Grupos de Recursos").Range("a12") 
    For Contador_BDP = Inicio_BDP To Final_BDP 
        Texto_BDP = Sheets("Grupos de Recursos").Range("b" & 3 + Contador_BDP & "") 
        If Sheets("GR0" & Contador_BDP & " - " & Texto_BDP & "").Visible = False Then 
            Sheets("GR0" & Contador_BDP & " - " & Texto_BDP & "").Visible = True 
        End If 
        Sheets("GR0" & Contador_BDP & " - " & Texto_BDP & "").Select 
        Application.Goto Reference:="EP.Fecha.GR0" & Contador_BDP & "" 
        Sheets("GR0" & Contador_BDP & " - " & Texto_BDP & "").Visible = False 
    Next Contador_BDP 
    Hoja2.Outline.ShowLevels Rowlevels:=1 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

What I am needing is a way to jump from one section of the module to another section. It runs a validation step first then once completed I need it to run the email portion of the code. I have colored "RED" the two sections I need it to go from and to. Any help on this would be appreciated I have searched all over the forum and the net trying to find a way to make this work. This module runs when one button is pushed. Unless theres a way to assign two modules to a button in excel


Sub test()
Dim requiredCells As Variant
Dim prompts As Variant
Dim i As Long

 requiredCells = Array("a3", "d3", "h3", "k3")
 prompts = Array("Date", "Accounty Manager", "Warehouse From", "Warehouse To")

 For i = LBound(requiredCells) To UBound(requiredCells)
     If Range(requiredCells(i)).Value = vbNullString Then
         Range(requiredCells(i)).Value = userInput(prompts(i))
         If Range(requiredCells(i)).Value = vbNullString Then Exit Sub: Rem Cancel pressed
     End If
 Next i

End Sub
Function userInput(promptString As Variant) As String
    userInput = Application.InputBox("You must enter a " & promptString, Type:=2)
    If userInput = "False" Then userInput = vbNullString: Exit Function
Loop Until userInput <> vbNullString
End Function

Sub Mail_workbook_Outlook_2()
'Working in 2000-2007
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object
    Set wb1 = ActiveWorkbook
    If Val(Application.Version) >= 12 Then
        If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
            MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." &
vbNewLine & _
                   "Save the file first as xlsm and then try the macro again.", vbInformation
            Exit Sub
        End If
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Make a copy of the file/Open it/Mail it/Delete it
    'If you want to change the file name then change only TempFileName
    TempFilePath = Environ$("temp") & ""
    TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "fizgigjk@yahoo.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add wb2.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    wb2.Close SaveChanges:=False
    'Delete the file
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
End Sub

The following is the code I am using to open my data table in a second workbook, refresh the table and then copy to results to the first workbook. When it runs, the second workbook is not updating with new data.

    Dim Answer As String 
    Dim MyNote As String 
    MyNote = "Master List Update can take up to 5 minutes to complete...Continue?" 
    Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "???") 
    If Answer = vbNo Then 
        Dim wb2 As Workbook 
        Set wb2 = Application.Workbooks.Open("[URL="file://pmcfsgroupsBusiness"]pmcfsgroupsBusiness[/URL]
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
        :=False, Transpose:=False 
        Application.DisplayAlerts = False 
        Application.DisplayAlerts = True 
    End If 
End If 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
thanks for any help on this.


Hello heroes,

Long time lurker, first time poster - I have searched EVERYWHERE.

Anyways, the title is just the tip of the iceberg so I will do my best to explain - if I can clear anything up for you further, please ask.
To prelude, it should be noted that I deleted a LOT of information/code, but I believe all of the relevant items are still there. Second, I only taught myself coding about a month ago so please bear with me.

On my attached workbook, I pull information in from an external source to populate Sheet 1 (Rate_Link). Upon pulling in the information, Column G is inserted to create a Concatenation column out of the initial pulled data. Next, data selected by the users from the boxes in Sheets("Main") is sourced to cells in Sheet 9 (Population_Key), then concatenated into Cell $H$1. Using the Concatenation in $H$1, I use a macro attached to a button to apply a formula array of multiple-vlookups [(because 2 values exist for 1 concatenation) from VBA Inserted Column G & Column H on Sheet 1 (Rate_Link)], then the button performs a 'paste special' of sorts to remove the "empty" (blank valued formulas) cells, leaving merely the values "A,B" in Column L. The next step in my process would be to apply a dynamic name to the results in Column L and use it in a Combo Box.

Here's my problem: When I open the workbook, the inserting of column G shifts the multiple vlookup array 1-3 columns to the right to make the array, usually $I$1:$J$? instead of $G$1:$H$?.

NOTE: I deleted the Insert Column G on Workbook Open, because I was torn between leaving the formatting/document proper/'working' and keeping the document authentic (with the on open code).

I know this is a sub-question, but it is directly related to my individual cause and the exact same set of cells:
Further, I wanted to NOT have the code on a button (though it is present and currently working) but on a worksheet change event with Sheet 11, in the event that all 4 criteria are satisfied (no cell = 0). I tried with an ELSE Run or Call Macro (RouteListMacro), but it didn't work (even though the command button with this macro does) so I established a Do Loop Until on the Worksheet Change, but it does not register. I think this issue might be directly related to the Array shift I described above, but I am uncertain. I say this because I initially had it working, but had closed the workbook then reopened and it was no longer working.

Thank you in advance for you help and your contribution to my future knowledge.


I am currently working on this project where I have to take 2 workbooks and merge 2 sheets together( Sheet1 on both workbooks are populated only). I have figured out a way to open both the workbook sheets and put info on one master excel sheet (This is a separate workbook that stores the info along with the vba code). What I'm running into is that it populates the info from workbook1 on the top then populates info from workbook2 underneath it. I have attached the way the sheets are populated below along with the code that I have so far. If anyone can let me know exactly what I should be doing that be grate help. I have windows2003 and the client might have win2002, I'm thinking it should be ok.

Workbook1.sheet1 (nameage.xls)
EE ID Name Age Reason Amt
2 B 12 123
1 A 23 54
3 C 55 785
5 E 56 45
4 D 29 477
6 F 45 456
7 G 44 2323

Workbook2.sheet2 (namejob.xls)
EE ID Name Job Reason
1 A Marketing 10
2 B Sales 20
3 C Data Entry 30
4 D Timer 50
5 E Banker 80

Expected Output in Master.xls after macro runs
EE ID Name Age Reason Amt Job
2 B 12 20 123 Sales
1 A 23 10 54 Marketing
3 C 55 30 785 Data Entry
5 E 56 80 45 Banker
4 D 29 50 477 Timer
6 F 45 456
7 G 44 2323

    Dim basebook As Workbook 
    Dim mybook As Workbook 
    Dim sourceRange As Range 
    Dim destrange As Range 
    Dim SourceRcount As Long 
    Dim N As Long 
    Dim rnum As Long 
    Dim MyPath As String 
    Dim SaveDriveDir As String 
    Dim FName As Variant 
    SaveDriveDir = CurDir 
    MyPath = "C:excel" 
    ChDrive MyPath 
    ChDir MyPath 
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", _ 
    If IsArray(FName) Then 
        Application.ScreenUpdating = False 
        Set basebook = ThisWorkbook 
        rnum = 1 
         'clear all cells on the first sheet
        For N = LBound(FName) To UBound(FName) 
            Set mybook = Workbooks.Open(FName(N)) 
            Set sourceRange = mybook.Worksheets(1).Range("A1:D10") 
            SourceRcount = sourceRange.Rows.Count 
            Set destrange = basebook.Worksheets(1).Cells(rnum, "A") 
            With sourceRange 
                Set destrange = basebook.Worksheets(1).Cells(rnum, "A"). _ 
                Resize(.Rows.Count, .Columns.Count) 
            End With 
            destrange.Value = sourceRange.Value 
            mybook.Close False 
            rnum = rnum + SourceRcount 
    End If 
    ChDrive SaveDriveDir 
    ChDir SaveDriveDir 
    Application.ScreenUpdating = True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


It seems that I have been posting on here almost once a day, so to keep with tradition, today's question is...

I have an excel workbook with 10 sheets; What I would like to do: On the first work-day of each month, I would like Sheet4 and Sheet10 to save-as together in their own workbook seperate of the main workbook, with the Month/Year in the name. Once they are saved, I would then like those two sheets to be erased except for the first row of each sheet. How can I do this with code in vba?

This is my 2nd week using VBA and excel, so any code would be much appreciated. Thanks in advance!

(The reason I need this to happen and not just open a blank file once a month, is because other sheets in the file have over 90,000 running averages combined that are updated every day, i need those to remain throughout the year)

First some background on why I'm interested in an answer to the question. I'm employed as a Test Engineer for integrated circuits and the (million+ dollar) machines we use, believe it or not, run on Microsoft Excel. This also means our test programs are written in VBA.

Typically, I set a breakpoint somewhere in the code, run to that point and try to figure out what the device is doing by reading/writing to it's serial port (all in VBA code). So if I have a function that knows how to get the information I'm looking for called GetTheInfo(), then I would open the Immediate window, type the code, and run it. But if what I needed to run was something like a userform, then I couldn't do that because you cannot run some other set of VBA code if the debugger is "paused".

So now I'm considering using VB to create the userform and have it call the GetTheInfo() that is buried in the workbook's VBA code. Is this possible? Can A VB application run code that is within an open workbook when Excel's VBA debugger is paused on some line of code?

I guess another question would be, is it possible to run a userform when the VBA debugger is paused?


The code below works perfectly for what I need to do, which is to open and copy (or move) the first sheet of each of the workbooks in a single folder to a master WB that resides outside of that folder, then break the links to the source workbooks. However, every time I run the code, twenty-seven of the workbooks open and close before the next one opens (as they should), but the same five workbooks stay open after the code completes. The first sheet of each of these moves to the master WB like all the others, but they do not close after the move. I can't see any obvious difference between the WBs that stay open and the ones that close. Could someone please point me in the general direction of where the problem lies? I am using Excel 2007 but this needs to also run on 2003. Thanks! (All my codes are piecemeal, as I am a beginner who finds code on online and adapts it to what I need to do, so that's why it looks like it does.)

Here's the code:

    Dim Fpath As String, Fname As String 
    With Application 
        .ScreenUpdating = False 
        .Calculation = xlCalculationManual 
        .EnableEvents = False 
    End With 
    Fpath = "sserfs.graytv.corpUsers$don.mastersExcel Projects2012 NOPstation files" 
    Fname = Dir(Fpath & "*.xls") 
    With Workbooks("NOP.xls") 'MUST BE OPEN
        Do While Fname  "" 
            If Fname  .Name Then 
                Workbooks.Open Fpath & Fname 
                Workbooks(Fname).Sheets(1).Move After:=.Sheets(.Sheets.Count) 
            End If 
            Fname = Dir 
    End With 
    With Application 
        .ScreenUpdating = True 
        .Calculation = xlCalculationAutomatic 
        .EnableEvents = True 
    End With 
    Dim i As Integer 
    Dim varLinks As Variant 
    varLinks = ActiveWorkbook.LinkSources(xlLinkTypeExcelLinks) 
    For i = UBound(varLinks) To LBound(varLinks) Step -1 
        ActiveWorkbook.BreakLink varLinks(i), xlLinkTypeExcelLinks 
    Next i 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I'll explain to you my problem:

I have an excel spreadsheet with 4 different tabs.

the first tab needs to have the dropdown for the user to select a database.

the second and third tabs are pivot tables created in vba

the fourth tab are the columns that run the pivot tables.

Now I have a stored proc in SQL Server 2000 that has an input parameter called 'Matter'. Once the user selects the database...that database needs to be fed into the stored proc to run it only against that particular database and then the results should come back to the first tab.

The code I have in my spreadsheet for the form is as follows:

Const stCon    As String = "Provider=SQLOLEDB;" & _ 
"DATA SOURCE=dr-ny-sql001; INITIAL CATALOG=master;" & _ 
Private Sub cmdClose_Click() 
     'close the form
    Unload Me 
End Sub 
Private Sub chkmat_Click() 
     'This is where you can add a  filter by the year
    Dim stSQL  As String 
    Dim cnt    As ADODB.Connection 
    Dim rst    As ADODB.Recordset 
    Dim vaData As Variant 
     'Just select the Distinct databases from sysdatabases Table to load into matter  Combobox
    stSQL = "SELECT distinct  name  FROM sysdatabases where name like 'client%';" 
    If chkmat.Value = True Then 
         'if the year filter checkbox is checked
        Set cnt = New ADODB.Connection 
        Set rst = New ADODB.Recordset 
        cnt.ConnectionString = stCon 
        With cnt 
            .CursorLocation = adUseClient 'Necesary for creating disconnected recordset.
            .Open stCon 'Open connection.
             'Execute the SQL statement.
            Set rst = .Execute(stSQL) 
        End With 
        With rst 
            Set .ActiveConnection = Nothing 'Disconnect the recordset.
             'Populate the array with the whole recordset.
            vaData = .GetRows 
        End With 
         'Close the connection.
        With Me 
            With .cmbmat 
                 'load the query result into combobox
                .List = Application.Transpose(vaData) 
                .ListIndex = -1 
            End With 
        End With 
        With Me 
            With .cmbmat 
            End With 
        End With 
    End If 
End Sub 
Private Sub cmdQuery_Click() 
     'run query to find records
    Dim stParam As String, stParam2 As String 
    Dim stSQL  As String 
    Dim cnt    As ADODB.Connection 
    Dim rst    As ADODB.Recordset 
    Dim fld    As ADODB.Field 
    Dim wsSheet As  Worksheet, wbBook As Workbook 
    Dim i As Long, j As Long, x As Integer 
     'initial SQL to return all records
    stSQL = "SELECT * FROM sysdatabases" 
     'set the parameter strings
    stParam = " WHERE Name = " & Me.cmbmat.Text 
    stParam2 = " ;" 
     'check & build  variable parameters
     'depending on whether checkbox ticked by user
    If Me.chkmat.Value = True Then 
        stSQL = stSQL & stParam & stParam2 
    Else: stSQL = stSQL & stParam2 
    End If 
    On  Error Goto ErrHandle 
    Set cnt = New ADODB.Connection 
    Set rst = New ADODB.Recordset 
    Set wbBook = ThisWorkbook 
    Set wsSheet = ThisWorkbook.Worksheets(1) 
    With cnt 
        .ConnectionString = stCon 
    End With 
    With rst 
        .CursorLocation = adUseClient 
        .Open stSQL, cnt, adOpenStatic, adLockReadOnly 
        .ActiveConnection = Nothing 'Here we disconnect the recordset.
        j = .Fields.Count 
        i = .RecordCount 
    End With 
    With wsSheet 
        If i = 0 Then Goto i_Err 
         'Write the fieldnames to the fifth row in the worksheet
        For x = 0 To j - 1 
            .Cells(5, x + 1).Value = rst.Fields(x).Name 
        Next x 
         'Dump the data to the worksheet.
        .Cells(6, 1).CopyFromRecordset rst 
    End With 
    If CBool(rst.State And adStateOpen) = True Then rst.Close 
    Set rst = Nothing 
    If CBool(cnt.State And adStateOpen) = True Then cnt.Close 
    Set cnt = Nothing 
    Exit Sub 
    Dim cnErrors As ADODB.Errors 
    Dim ErrorItem As ADODB.Error 
    Dim stError As String 
    Set cnErrors = cnt.Errors 
    With Err 
        stError = stError & vbCrLf & "VBA Error # : " & CStr(.Number) 
        stError = stError & vbCrLf & "Generated by : " & .Source 
        stError = stError & vbCrLf & "Description : " & .Description 
    End With 
    For Each ErrorItem In cnErrors 
        With ErrorItem 
            stError = stError & vbCrLf & "ADO error # : " & CStr(.Number) 
            stError = stError & vbCrLf & "Description : " & .Description 
            stError = stError & vbCrLf & "Source : " & .Source 
            stError = stError & vbCrLf & "SQL State : " & .SqlState 
        End With 
    Next ErrorItem 
    MsgBox stError, vbCritical, "SystemError" 
    Resume ExitHere 
    MsgBox "There are no records for this Query" 
    Goto ExitHere 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

the code I have for the first tab is as follows:

Sub Preview_Report() 
    Dim cn As ADODB.Connection 
    Dim cmd As ADODB.Command 
    Dim rs As ADODB.Recordset 
    Dim strConn As String 
    Set cn = New ADODB.Connection 
    Dim strServer As String, strDatabase As String 
    strServer = "dr-ny-sql001" 
    strDatabase = "master" 
     'Use the SQL Server ODBC Provider.
     'strConn = "Driver={SQL Server};Server=" & strServer & ";Database=" & strDatabase & ";Uid=" & strUser & ";Pwd=" &
strPassword & ";"
     'Use the SQL Server OLE DB Provider.
     'strConn = "Provider=SQLOLEDB;Data Source=" & strServer & ";Initial Catalog=" & strDatabase & ";User Id=" & strUser &
";Password=" & strPassword & ";"
    strConn = "PROVIDER=SQLOLEDB;" 
     'Connect to the Pubs database on the local server.
    strConn = strConn & "DATA SOURCE=" & strServer & ";INITIAL CATALOG=" & strDatabase & ";" 
     'Use an integrated login.
    strConn = strConn & " INTEGRATED SECURITY=sspi;" 
     'Now open the connection.
    cn.Open strConn 
    Set cmd = New ADODB.Command 
    cmd.ActiveConnection = cn 
    cmd.CommandText = "master.dbo.usp_DR_Preview_test" 'Name of stored procedure
    With cmd 
        .Parameters.Append .CreateParameter("Client_Lehman_ASARCO", adVarChar, adParamInput, 100, Range("D2")) ' Character
value of no more than 255 bytes
         ' Other possible parameter types
         '.Parameters.Append .CreateParameter("QueryTextParam", adVarChar, adParamInput, 10, "Value")
         '.Parameters.Append .CreateParameter("QueryLongParam", adBigInt, adParamInput, , LongValue)
         '.Parameters.Append .CreateParameter("QueryDateParam", adDate, adParamInput, , DateValue)
         '.Parameters.Append .CreateParameter("QueryDateTimeStampParam", adDBTimeStamp, adParamInput, , DateTimeValue)
         '.Parameters.Append .CreateParameter("BooleanParam", adBoolean, adParamInput, , BooleanValue)
    End With 
    cmd.CommandType = adCmdStoredProc 
    Set rs = New ADODB.Recordset 
     'With rs
     '.Source = "SET NOCOUNT ON"
     '.ActiveConnection = cn
     'End With
    Set rs = cmd.Execute() 
     'If Not rs.EOF Then
    Worksheets("Sheet1").Range("A15").CopyFromRecordset rs 
     'MsgBox "No data returned from stored procedure: '" & "usp_DR_Preview_test" & "' using parameter value: " & Range("D2")
     'End If
    Set rs = Nothing 
    Set cn = Nothing 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

this code does not work. it does not run the stored proc...it only created the temp tables.

In the fourth tab i am running the code off another stored procedure.

Is there any way to achieve this?????

I am pulling my hair out already!!!

Thanks a lot for your help!


Hi everyone,
I am working on creating a automate Timesheet. The timesheet will have information about the employee's id, department, first name and last name. In the timesheet it will also includes the first date until the fourteenth date of the bi-weekly payroll. The date will be created automatically when msgbox pop-up asking which week I want to work on (see below: "iInput code").
This code below involves 2 excel files. The first file (MasterfileAuditReport.xls)contains employees' name, id, department and their status (active, terminated, etc). The second file (Timesheet.xls) will be created from VBA code in the first file.
But when I tried to run the following VBA script on the first file, I ran into the following error message "Run-time error '9': Subscript out of range" on this line (with '****' sign).
I have been working on this VBA for few weeks but I couldn't find out how to fix this problem.
I hope some of you can give me some suggestion and help.
I really appriciate this, thank you in advance.
Have a nice day.

     'Variable for Workbook
    Dim sDepartment As String 
    Dim sID As String 
    Dim sName As String 
     'Variables for MasterFile
    Dim iColumn As Integer 
    Dim iRow As Integer 
    Dim sCellValue As String 
    Dim sCellValue1 As String 
    Dim sCellValue2 As String 
    Dim sCellValue3 As String 
     'Varibles for Calendar
    Dim iInput As Integer 
    Dim dInitialDate As Date 
    Dim dDateOfWeek As Date 
    Dim iLoopValue As Integer 
    Dim NewArray(1 To 15) As Date 
    Dim LoopArray As Integer 
    Dim iRow1 As Integer 
    Dim iRow2 As Integer 
    iRow1 = 9 
    iRow2 = 18 
     'Open the Timesheet workbook
     'Workbooks.Open Filename:="Timesheet.xls"
     'Code to clean up Master file starts here
    sCellValue1 = "Terminated" 
    sCellValue2 = "On Leave of Absence" 
    sCellValue3 = "Deceased" 
    iColumn = 12 
    iRow = 12 
    iInput = InputBox("Which Payroll Period do you want to generate?") 
    dInitialDate = "10/31/2004" 
    iLoopValue = 0 
    dDateOfWeek = dInitialDate + (iInput * 14) 
    LoopArray = iLoopValue + 1 
    dDateOfWeek = dDateOfWeek - 1 
     'Loop Starts
     'Do Until IsEmpty(Workbooks("Masterfile.xls").Worksheets(1).Cells(iRow, 12))
     'sCellValue = Workbooks("masterfile.xls").Worksheets(1).Cells(iRow, 12).Value
     'If sCellValue = sCellValue1 Or sCellValue = sCellValue2 Or sCellValue = sCellValue3 Then
     'ActiveSheet.Cells(iRow, 12).Select
     'iRow = iRow + 1
     'End If
     'Code to get info for Department, ID and Name from Mastefile.xls
    Do Until IsEmpty(Workbooks("Masterfile.xls").Worksheets(1).Cells(iRow, 1)) 
         'Code to create calendar starts here
         'Loop for the first week
        Do While iLoopValue < 7 
            dDateOfWeek = dDateOfWeek + 1 
            NewArray(LoopArray) = dDateOfWeek 
            Cells((LoopArray + 8), 2).Clear 
            Cells((LoopArray + 8), 2) = NewArray(LoopArray) 
            LoopArray = LoopArray + 1 
            iLoopValue = iLoopValue + 1 
         'Loop for the second week
        Do While iLoopValue < 14 
            dDateOfWeek = dDateOfWeek + 1 
            NewArray(LoopArray) = dDateOfWeek 
            Cells((LoopArray + 10), 2).Clear 
            Cells((LoopArray + 10), 2) = NewArray(LoopArray) 
            LoopArray = LoopArray + 1 
            iLoopValue = iLoopValue + 1 
         'Beginning Date
        Cells(2, 9).Clear 
        Cells(2, 9) = NewArray(1) 
        Cells(2, 11).Clear 
        Cells(2, 11) = NewArray(14) 
        Workbooks("Masterfile.xls").Worksheets(1).Cells(iRow, 1) = sDepartment 
        Workbooks("Masterfile.xls").Worksheets(1).Cells(iRow, 1).Copy 
        Workbooks("Timesheet.xls").Worksheets(1).Cells(3, 2).PasteSpecial 
        Workbooks("Masterfile.xls").Worksheets(1).Cells(iRow, 2) = sID 
        Workbooks("Masterfile.xls").Worksheets(1).Cells(iRow, 2).Copy 
        Workbooks("Timesheet.xls").Worksheets(1).Cells(2, 6).PasteSpecial 
        Workbooks("Masterfile.xls").Worksheets(1).Cells(iRow, 3) = sName 
        Workbooks("Masterfile.xls").Worksheets(1).Cells(iRow, 3).Copy 
        Workbooks("Timesheet.xls").Worksheets(1).Cells(2, 2).PasteSpecial 
        ThisWorkbook.SaveAs Filename:=sName & ".xls", FileFormat:=xlWorkbookNormal 
        sDepartment = " " 
        sID = " " 
        sName = " " 
        iRow = iRow + 1 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

Firstly, thank you for reading this. I am very much a VBA newbie, so any help is greatly appreciated.

I have a workbook ("Scorecard_working template.xls") with sheets "Open Items" and "Closed Observations" and a macro code on Excel 2003.

The macros run just fine on the computer it were written on, but when I try to run them on the workbook from another computer (runs Excel 2003 also), I get the error message "Method 'Copy' of object 'Range' failed" on the Excel screen and the message "The object invoked has disconnected from its clients" on the VBA screen; Excel also seems to freeze up, and I can't select cells. Is there something I can fix to get the macros to run correctly on other computers?

The first macro is intended to move a row from "Open Items" to "Closed Observations" when a row is marked "Closed" in Column R:

    Dim rng As Range, usedcell As Range 
    Dim lastrow As Long, x As Boolean 
    Set rng = Intersect(Sheets("Open Items Track List").UsedRange, _ 
    Sheets("Open Items Track List").Range("R:R")) 
    For Each usedcell In rng 
        x = Evaluate("=NOT(ISERROR(SEARCH(""Closed""," & usedcell.Address & ",1)))") 
        If x Then 
            lastrow = Sheets("Closed Observations").Cells(Rows.Count, "R").End(xlUp).Row 
             'This is where the debugger highlights the error
            Sheets("Open Items Track List").Rows(usedcell.Row).Copy Sheets("Closed Observations").Rows(lastrow + 1) 
            Sheets("Open Items Track List").Rows(usedcell.Row).ClearContents 
        End If 
    Next usedcell 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The second macro is intended to move a row from "Closed Observations" to "Open Items" when a row is marked "Open" in Column W:

 x () 
    Dim rng As Range 
    Set rng = Intersect(Sheets(“Closed Observations”).UsedRange, _ 
    Sheets(“Closed Observations”).Columns (“W”)) 
    For Each rng In Columns (“W”).SpecialCells(x1CellTypeConstants).Areas 
        Select Case rng(1) 
        Case “Open” 
            Rows(rng(1).Row).Cut Sheets(“Open Items Track List”).Rows(Count + 1).Offset(1,0) 
        End Select 
    Next rng 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Your help is very much appreciated, thank you in advance!

Hello folks

First post by a one-week-in user of VBA. Thanks to those questioners and contributors whose posts have helped me get to this point.

I have been developing code to update data in two workbooks and then transfer rows of data within and between them. I'm using Excel 2003.

My code is probably pretty clumsy, but it works in the two workbooks I wrote it in. Knowing the workbooks would be shared in the final environment I checked the restrictions on shared workbooks and, as far as I know, I haven't broken these.

The interface is all through user-forms with the bulk of the code running on a click of OK.

When I change to the workbook to Shared and start using it (still without any other versions running) I get run-time error messages. This happens whether I'm calling a macro that moves rows of data or one that simply updates cells an existing record and also happens when only one of the worklbooks is open and called to do an activity that does not reference the other.

Undoing the share option gets everything working normally again.

The two run-time error messages I've seen most are 1004 "Unable to set the MergeCells property of the Range class" and 9 "Subscript out of range". The only merged cells are on the top row of each worksheet (where the macro buttons are) and shouldn't be affected by any of the activities I'm running.

Do I need to revisit my code (about 10 routines) section by section or are there "known issues" and workarounds for macros in shared workbooks.

I haven't posted any code, because this seems to be an issue regardless of the macro called (and because my code is about as elegant as bull in a frock).

Thanks for reading this far,


I am sure that there is a way to do this but I don't know enough VBA to make this work. I would REALLY appreciate it if some kind soul out there would help me.

I work at a hotel, and every day I have to hand-write coupons for breakfast for each of our guests who arrive for certain local accounts that we have, and I need a separate coupon for each day they are staying. As you can imagine, this is very time consuming.

I had a similar situation a few months ago with guests who arrived and were part of our frequent stay program, and someone was kind enough to help me by writing a VBA code to run a macro to solve that problem. Unfortunately that macro will not work in this situation, as the report that I run from my system for this is not in the same format.

Since the people who will be using this spreadsheet and macro are my employees and may not know excel as well as I do, I need to do this in as few steps as possible. They are already familiar with importing data from another excel file and using Ctrl Q to run the macro. My coupon workbook is saved as password protected, with a prompt to open as read-only so that it can’t be messed up by someone by accident. (Password for attached file is password, no caps)

Currently we run a report from our reservation system, export it to excel, and save it to the desktop. Then we open the workbook that has the breakfast coupons in it. On the first tab they select import data and then select the saved excel file to import from. Then they go to the second tab in the coupons workbook and run the macro by using Ctrl Q. This creates the right number of coupons for each guest based on the number of days that they are staying with us.

In this first instance the report that I run has already sorted the guests, so it only includes the guests who I need coupons for. For this new set of coupons I need to not only account for the number of days a guest is staying, but for the coupons to be run only for certain guests based on the “code” that their reservation was booked under, as the report I can run from my system for this will not sort them first.

The report that I run from my system shows all arrivals for a given day or set of days. Each arrival will have a special code which shows what account they booked their reservation with.

I need a macro that will create coupons only for people fitting a certain set of codes. Also, I will need to be able to modify the list of included codes later in case we add any new codes or lose any current ones.

I have attached a copy of the files and reports that I am currently using.

The first file is the coupon workbook that I use. (Password is password, no caps) - Sorry I could not include this. Try as I might, I could not get it to fit the file size, not sure why. I will be happy to email this to someone who is interested!

The second file shows the report that we use for our frequent stay guests and import into the coupon workbook to make the coupons for them. (I show this just so you can see what already works) - Sorry, There is a maximum of 2 attachments per post. Again, I will be happy to email!

The third file is the report which I have which shows arrivals based on their booking “code”. This is listed in the far right column (the C-, L-, or S- before the 3 letter code can be ignored).

The fourth file is a list which shows what special rate codes include breakfast (all those which say BF). Guests who are listed in the third file, which shows arrivals based on their booking code, would need to be sorted using this information, to have coupons made for them.

Please note: All names have been changed and company names removed from these files for privacy purposes.

I know this is rather complicated, but I have attached all of the current files I have in the hopes that it will make things easier if someone chooses to help me.

Thank you in advance to anyone who has the chance to assist me with this!

I created a macro enabled workbook in Excel 2010, opened it during a meeting with a colleague on a different laptop that runs Office 2003, made a couple changes during the meeting and saved it as a macro enabled 2007 .xlsm file. When I got back to my desk, with Office 2010, I got compile errors every time the code came to "Application.Calculation =" or "Application.ScreenUpdating =" - Calculation & ScreenUpdating are highlighted with the message, "Method or data member not found". When I type in the word "Application.", the options I get aren't ones I have seen before. If I choose any of them, the definition says they come from the MSForms.Frame library.
I was able to edit the code to just say, "Calculation =" & "ScreenUpdating =" (without the "." in front) and it seems to run fine on my machine now, but I'd like to know why this happened, plus, I have never seen anything coded like this before?
I see the Object libraries on my machine (14.0) are different than the meeting room laptop (11.0), but this is a tool that will be released to our customers when it is finished & many of them still run Excel 97-2003. Will this be a problem?
I am relatively new to VBA & have taught myself by searching forums like this, but have never had a problem before - but this is the first tool I've created in Excel 2010 and I don't want to release something to our customers if it will cause problems. Would it be better if I didn't create .xlsm files, and just stuck with saving them as 97-2003 .xls files? Will that eliminate the problem or is it something else?
Thanks in advance for any help!

I have some VBA code that in one part of it a PivotTable is created on a separate worksheet. If I run the code in Excel 2002 or 2003, everything works fine. But, if I run the code in Excel, 2007, when the workbooks.open statement tries to re-open the workbook with the pivottable that was closed earlier in the VBA steps, I get a run-time error '1004': method 'open" of object 'workbooks' failed error.
If I manually try to open the work, Excel 2007 says to me that
"excel found unreadable content in the workbook. do you want to recover the contents? yes/no.
I say yes, then it'll open the workbook then a window opens saying
"repairs were made to the PivotTable report"
that the VBA created earlier in the processing
However, when I look at the PivotTable, the layout and data in it look exactly the same as how it looked when it was first created ( I took before and after screenshots and stepped through the VBA code at the PT's creation to confirm this) so I don't see what Excel is "repairing".
What do I change in my PivotTable VBA code so Excel 2007 will open it without any errors occuring? I'm pasting the code below.
thanks in advance,
LastRow = Cells(Rows.Count, "E").End(xlUp).Row
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
"CABNEWB!R1C1:R" & LastRow & "C28", TableDestination:="", TableName:="PivotTable3"
ActiveSheet.PivotTables("PivotTable3").AddFields RowFields:=Array("FACILITY", _
With ActiveSheet.PivotTables("PivotTable3").PivotFields("BAL")
.Orientation = xlDataField
.Position = 1
.Name = "Count of BAL"
.Function = xlCount
End With
With ActiveSheet.PivotTables("PivotTable3").PivotFields("BAL")
.Orientation = xlDataField
.Name = "Sum of BAL"
.Function = xlSum
End With
ActiveSheet.PivotTables("PivotTable3").PivotSelect "Data[All]", xlLabelOnly
With ActiveSheet.PivotTables("PivotTable3").PivotFields("Data")
.Orientation = xlColumnField
.Position = 1
End With

ActiveSheet.PivotTables("PivotTable3").PivotSelect "", xlDataAndLabel