Use this UDF created in Excel in Access

silentwolf

Well-known Member
Joined
May 14, 2008
Messages
1,123
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:

Some videos you may like

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
35,523
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS
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.
 

silentwolf

Well-known Member
Joined
May 14, 2008
Messages
1,123
Office Version
  1. 2016
Hi Rory,

many thanks that should get me started!

Cheers
 

silentwolf

Well-known Member
Joined
May 14, 2008
Messages
1,123
Office Version
  1. 2016
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...
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
35,523
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

Clearly you can't refer to ThisWorkbook in Access since your database is not a workbook. Replace it with wbkQuelle
 

silentwolf

Well-known Member
Joined
May 14, 2008
Messages
1,123
Office Version
  1. 2016
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
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
35,523
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

You only replace thisworkbook so this:

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

becomes this:

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

silentwolf

Well-known Member
Joined
May 14, 2008
Messages
1,123
Office Version
  1. 2016
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:

silentwolf

Well-known Member
Joined
May 14, 2008
Messages
1,123
Office Version
  1. 2016
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.
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
35,523
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,550
Messages
5,529,472
Members
409,884
Latest member
Msinmath
Top