Use this UDF created in Excel in Access

silentwolf

Well-known Member
Joined
May 14, 2008
Messages
1,216
Office Version
  1. 2016
Hi guys,
I was hoping for some help.

Code:
Sub Importieren()
    Dim appExcel As Excel.Application
    Dim objFiledialog As FileDialog
    Dim FileWasChosen As Boolean

    Dim wbkQuelle As Workbook
    Dim wksQuelle As Worksheet
    Dim varPfadDatei As Variant
    Dim wksZiel As Worksheet

    Dim strFileName As String

    Set appExcel = HoleAnwendung("Excel.Application")

    varPfadDatei = appExcel.Application.GetOpenFilename("Alle Daten,*.xl*,Text Dateien, *.csv*", 1, "Daten auswählen", , False)

    If varPfadDatei = False Then
        Exit Sub
    End If

        Set wbkQuelle = Workbooks.Open(varPfadDatei)
        Set wksQuelle = wbkQuelle.Worksheets(1)

        strFileName = wbkQuelle.Name
        strFileName = Replace(NurDatei(varPfadDatei), ".xlsx", "")
    
    If WorksheetExists(strFileName) Then
        MsgBox "Blatt wurde bereits importiert!", vbInformation, p_cstrAppTitel
        wbkQuelle.Close xlDoNotSaveChanges
        Exit Sub
    Else
        Set wksZiel = ThisWorkbook.Worksheets.Add()
        wksZiel.Name = strFileName

        wksQuelle.UsedRange.Copy wksZiel.Cells(1, 1)

    End If

    wbkQuelle.Close xlDoNotSaveChanges

    Set wbkQuelle = Nothing
    Set wksZiel = Nothing
End Sub

Code:
Public Function WorksheetExists(strBlattName As String) As Boolean
    Dim objBlatt As Object
    
    WorksheetExists = False
[COLOR=#ff0000]    For Each objBlatt In ThisWorkbook.Sheets[/COLOR]
        If objBlatt.Name = strBlattName Then
            WorksheetExists = True
            Exit For
        End If
    Next objBlatt
End Function

the above sub calls the function I have created both in excel and it works fine. However as I like to run all my code out of access I would need to modify this peace of code so it works also there.
The sub is working modified to suit in access as shown above with a littel UDF "HoleAnwendung" which is translated "GetApplication" .. reference to Excel libary is set and the first part works fine.
However when it goes into WorksheetExist the code stops at marked text in red.

Run-time error '1004' : Method 'Range' of object'_Global' failed

So what needs to be done so it can reconise this object


Hope someone could please help me on this.
 
Last edited by a moderator:

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Alter it to take a workbook object:

Code:
Public Function WorksheetExists(strBlattName As String, wb as Excel.Workbook) As Boolean
    Dim objBlatt As Object
    
    WorksheetExists = False
    For Each objBlatt In wb.Sheets
        If objBlatt.Name = strBlattName Then
            WorksheetExists = True
            Exit For
        End If
    Next objBlatt
End Function

then pass the workbook when you call it.
 
Upvote 0
Hi again,
sorry but there is another issue with this code (

Code:
        Set wbkQuelle = Workbooks.Open(varPfadDatei)
        Set wksQuelle = wbkQuelle.Worksheets(1)

        strFileName = wbkQuelle.Name
        strFileName = Replace(NurDatei(varPfadDatei), ".xlsx", "")
    
    If WorksheetExists(strFileName, wbkQuelle) Then
        MsgBox "Blatt wurde bereits importiert!", vbInformation, p_cstrAppTitel
        wbkQuelle.Close xlDoNotSaveChanges
        Exit Sub
    Else
       [COLOR=#ff0000] Set wksZiel = ThisWorkbook.Worksheets.Add()[/COLOR]
        wksZiel.Name = strFileName

        wksQuelle.UsedRange.Copy wksZiel.Cells(1, 1)

    End If

    wbkQuelle.Close xlDoNotSaveChanges

it is not opening any worksheet and jumps into the MsgBox "Blatt wurde bereits importiert!", vbInformation, p_cstrAppTitel

Means the code thinks there has been alreade this worksheet been importet

Sorry for this...
 
Upvote 0
Clearly you can't refer to ThisWorkbook in Access since your database is not a workbook. Replace it with wbkQuelle
 
Upvote 0
Yes I thought so but I just can t seam to get it to work unfortunatelly .(

I tried

Set wksZiel = wbkQuelle

or
Set wksZiel = wbkQuelle.add()

hmm
 
Upvote 0
You only replace thisworkbook so this:

Code:
Set wksZiel = ThisWorkbook.Worksheets.Add()

becomes this:

Code:
Set wksZiel = wbkQuelle.Worksheets.Add()
 
Upvote 0
I guess I am to dumb for this.. :(


Code:
Sub Importieren()
    Dim appExcel As Excel.Application
    Dim objFiledialog As FileDialog
    Dim FileWasChosen As Boolean

    Dim wbkQuelle As Workbook
    Dim wksQuelle As Worksheet
    Dim varPfadDatei As Variant
    Dim wksZiel As Worksheet

    Dim strFileName As String

    Set appExcel = HoleAnwendung("Excel.Application")

    varPfadDatei = appExcel.Application.GetOpenFilename("Alle Daten,*.xl*,Text Dateien, *.csv*", 1, "Daten auswählen", , False)

    If varPfadDatei = False Then
        Exit Sub
    End If

        Set wbkQuelle = Workbooks.Open(varPfadDatei)
        Set wksQuelle = wbkQuelle.Worksheets(1)

        strFileName = wbkQuelle.Name
        strFileName = Replace(NurDatei(varPfadDatei), ".xlsx", "")
    
    If WorksheetExists(strFileName, wbkQuelle) Then
        MsgBox "Blatt wurde bereits importiert!", vbInformation, p_cstrAppTitel
        wbkQuelle.Close xlDoNotSaveChanges
        Exit Sub
    Else
        Set wksZiel = wbkQuelle.Worksheets.Add()
        wksZiel.Name = strFileName
        wksQuelle.UsedRange.Copy wksZiel.Cells(1, 1)
    End If

    wbkQuelle.Close xlDoNotSaveChanges

    Set wbkQuelle = Nothing
    Set wksZiel = Nothing
End Sub

Code:
Public Function WorksheetExists(strBlattName As String, wb As Excel.Workbook) As Boolean
    Dim objBlatt As Object
    
    WorksheetExists = False
    For Each objBlatt In wb.Sheets
        If objBlatt.Name = strBlattName Then
            WorksheetExists = True
            Exit For
        End If
    Next objBlatt
End Function

Code:
Function HoleAnwendung(strName As String) As Object
    On Error Resume Next
        Set HoleAnwendung = GetObject(, strName)
        If HoleAnwendung Is Nothing Then
            Set HoleAnwendung = CreateObject(strName)
        End If
End Function

This is what I got and when Excel is not running and I have closed the Processes in the task manager then it sometimes gives me also errors.

But manly it always jumps into the msgbox.
 
Last edited:
Upvote 0
Code:
Function NurDatei(ByVal strPfadDatei As String) As String
    Dim intPos As Integer
    
    intPos = InStrRev(strPfadDatei, "\")
    If intPos = 0 Then                  'dann war keine Datei darin enthalten
        NurDatei = ""
    Else
        NurDatei = Mid(strPfadDatei, intPos + 1)
    End If
End Function

This is a function used in the sub so I thought I poste it .. so if someone likes to try the code and can point out where it still is going wrong.
Also how would you change the GetObject to CreateObject ?

I believe this works better or at least on my machine.. as I had a while ago some issuse with it too. but can't find the file anymore.
 
Upvote 0
You should be using:

Rich (BB code):
Set wbkQuelle = appExcel.Workbooks.Open(varPfadDatei)

When automating one application from another you must properly qualify all objects.
 
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,941
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top