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

Opening Excel Workbooks with VBA

I have a form that's opening excel (if it's not already open), opening two seperate workbooks then looping through ranges to copy and paste values from one workbook to the other. This works fine if I don't have another instance of excel open and if I run the code once then open another instance of excel.

Issue: If I have an excel workbook open then run the code, the loop statement doesn't have an end point (loop continues on until accessis blown off).

I've provided an example. To keep this as simple as possible I have stripped out all unnecessary data and provided the three excel files the program is using. To test save all files to your C drive.

Any help here is appreciated. Thank you!
  • 2
  • 2
  • 2
1 Solution
Jeffrey CoachmanMIS LiasonCommented:
So this is being done through MS Access?

Seems like more of an Excel Question, but you posted it to the Access zone...?

twandsAuthor Commented:
Yes. I'm opening ExcelObjects but in Access VBA. Should I also post this question under Excel?
Jeffrey CoachmanMIS LiasonCommented:
No, I was just wondering if this was an Excel Q or an Access Q.

But it would not hurt to request that the Excel zone be added...


Easily Design & Build Your Next Website

Squarespace’s all-in-one platform gives you everything you need to express yourself creatively online, whether it is with a domain, website, or online store. Get started with your free trial today, and when ready, take 10% off your first purchase with offer code 'EXPERTS'.

I'm not surprised you're having difficulties, and I would note a few constructive points that should help.

You have a couple key statements:
    Set objWB1 = ExcelObject.Application.Workbooks.Open(sFile2)
    Set objWB2 = ExcelObject.Application.Workbooks.Open(sFile)

but then you start using Windows(excelfile).activate and you start directly reference sheet objects which have no parent, etc.

To control Excel, you must start with the Application Object, then Workbook Object, then Worksheet Object, then Range Object (for example).

So, heres a few statements in your code, but you have not referenced who owns the Cells, who owns the Sheets, etc.
Do Until IsEmpty(Cells(1, iCol))


    'copying the property name
    Sheets(1).Cells(1, iCol).Select
    Windows("Equity Template.xlsx").Activate
    Sheets(1).Cells(8, iCol2).Select
    Selection.PasteSpecial xlPasteValues

Open in new window

This particular snippet should be written something like:
dim wks1 as Excel.Worksheet
dim wks2 as Excel.Worksheet
dim r as Excel.Range

set wks1= objWB1.Sheets(1)
set wks2 = objWB2.Sheets(1)

Do Until IsEmpty(wks1.Cells(1, iCol))

    'copying the property name
    wks2.Cells(1, iCol).Select

    'Windows("Equity Template.xlsx").Activate

'Activate Workbook 1 as follows
'objWB1.Activate '<- this is the correct syntax

    wks1.Cells(8, iCol2).Select
    Selection.PasteSpecial xlPasteValues

Open in new window

Written again, optimized:
Dim wks1 As Excel.Worksheet
Dim wks2 As Excel.Worksheet
Dim r As Excel.Range

Set wks1 = objWB1.Sheets(1)
Set wks2 = objWB2.Sheets(1)

Do Until IsEmpty(wks1.Cells(1, iCol))

    'copying the property name
    wks2.Cells(1, iCol).Copy

    wks1.Cells(8, iCol2).PasteSpecial xlPasteValues

Open in new window

So, go through your code and ensure all your variables that reference excel object have ownership from the Application, to the Workbook, Sheet, then Range/Cell.

Hope this helps.

Here.  I think I got you half-way.  I wish I had renamed objWB1 to objEquity and objWB2 to objDummy as it would have helped, but check my work, and I think from this you should be ablel to finish out the rest ;)

Option Compare Database

Private Sub cmdEquity_Click()
On Error GoTo Err_cmdEquity_Click

    Dim sFile As String
    Dim sFile2 As String
    Dim ExcelObject As Excel.Application
    Dim sNewName As String
    Dim objWB1 As Excel.Workbook
    Dim objWB2 As Excel.Workbook
    Dim objWS1 As Excel.Worksheet
    Dim objWS2 As Excel.Worksheet
On Error Resume Next
    ' if excel is already open it uses that instance
    Set ExcelObject = GetObject(, "Excel.Application")

    ' if excel isn't open, it opens a new instance of excel
    If ExcelObject Is Nothing Then
        Set ExcelObject = New Excel.Application
        ExcelObject.EnableEvents = False
    End If

    'open excel shell file
    sFile2 = "C:\Equity Template.xlsx"
    sFile = "C:\Dump.xlsx"
    Set objWB1 = ExcelObject.Application.Workbooks.Open(sFile2) 'equity
    Set objWB2 = ExcelObject.Application.Workbooks.Open(sFile) 'dump
   'set the mouse pointer to an hourglass(wheel)
   SavedPointer = Screen.MousePointer
   Screen.MousePointer = 11

Dim iCol As Integer
Dim iCol2 As Integer

iCol = 3
iCol2 = 4


'copy over all the values to the 0-6 month tab of the template

Set objWS1 = objWB1.Sheets(1) 'equity
Set objWS2 = objWB2.Sheets(1) 'dump

Do Until IsEmpty(objWS2.Cells(1, iCol)) 'must be WB2 - last file opened


    'copying the property name
    objWS2.Cells(1, iCol).Copy
    objWS1.Cells(8, iCol2).PasteSpecial xlPasteValues
    'copying the city, state, zip, couty
    objWS2.Range(objWS2.Cells(3, iCol), objWS2.Cells(7, iCol)).Copy
    objWS1.Range(objWS1.Cells(9, iCol2), objWS1.Cells(13, iCol2)).PasteSpecial xlPasteValues
    'copying the units
    objWS2.Cells(8, iCol).Copy
    objWS1.Cells(15, iCol2).PasteSpecial xlPasteValues
    'copying project type section
    objWS2.Range(objWS2.Cells(9, iCol), objWS2.Cells(12, iCol)).Copy
    objWS1.Range(objWS1.Cells(17, iCol2), objWS1.Cells(20, iCol2)).PasteSpecial xlPasteValues

    'copying contact section
    objWS2.Range(objWS2.Cells(14, iCol), objWS2.Cells(16, iCol)).Copy
    objWS1.Range(objWS1.Cells(22, iCol2), objWS1.Cells(25, iCol2)).PasteSpecial xlPasteValues
    'copying tax credit section
    objWS2.Range(objWS2.Cells(18, iCol), objWS2.Cells(27, iCol)).Copy
    objWS1.Range(objWS1.Cells(27, iCol2), objWS1.Cells(36, iCol2)).PasteSpecial xlPasteValues
    'copying rehab section
    objWS2.Cells(29, iCol).Copy
    objWS1.Cells(39, iCol2).PasteSpecial xlPasteValues
    'copying demographic section
    objWS2.Range(objWS2.Cells(31, iCol), objWS2.Cells(35, iCol)).Copy
    objWS1.Range(objWS1.Cells(42, iCol2), objWS1.Cells(46, iCol2)).PasteSpecial xlPasteValues
    'copying subsidy section
    objWS2.Range(objWS2.Cells(37, iCol), objWS2.Cells(41, iCol)).Copy
    objWS1.Range(objWS1.Cells(49, iCol2), objWS1.Cells(53, iCol2)).PasteSpecial xlPasteValues

    'copying project section
    objWS2.Range(objWS2.Cells(43, iCol), objWS2.Cells(51, iCol)).Copy
    objWS1.Range(objWS1.Cells(56, iCol2), objWS1.Cells(64, iCol2)).PasteSpecial xlPasteValues

    iCol = iCol + 1
    iCol2 = iCol2 + 1

'delete all the blank columns at the end of the sheet
iCol2 = 8

    Do Until objWS1.Cells(8, iCol2).Interior.ColorIndex <> 37
        objWS1.Columns(iCol2).Delete Shift:=xlLeft

'convert all the unit totals to numbers
    iCol2 = 4
    Dim Val As String
    Do Until IsEmpty(objWS1.Cells(15, iCol2))
        objWS1.Cells(15, iCol2).NumberFormat = "General"
        objWS1.Cells(15, iCol2).Value = objWS1.Cells(15, iCol2).Value
        'Val = ActiveCell.Value
        'ActiveCell.Value = Val
        iCol2 = iCol2 + 1
'convert all the tax credit alloc cells to numbers
    iCol2 = 4
    Do Until IsEmpty(objWS1.Cells(28, iCol2))
        objWS1.Cells(28, iCol2).NumberFormat = "General"
        objWS1.Cells(28, iCol2).Value = objWS1.Cells(28, iCol2).Value
        'Val = ActiveCell.Value
        'ActiveCell.Value = Val
        iCol2 = iCol2 + 1
objWS2.Close savechanges:=False

Open in new window

Don't hesitate to post if you need additional help.


twandsAuthor Commented:
YES!! Thank you, this works perfectly!
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

7 new features that'll make your work life better

It’s our mission to create a product that solves the huge challenges you face at work every day. In case you missed it, here are 7 delightful things we've added recently to monday to make it even more awesome.

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