Use this UDF created in Excel in Access

[silentwolf]

Hi guys,
I was hoping for some help.

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

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.

 

[RoryA]

Alter it to take a workbook object:

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]

Hi Rory,

many thanks that should get me started!

Cheers

 

[silentwolf]

Hi again,
sorry but there is another issue with this 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]

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

 

[silentwolf]

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]

You only replace thisworkbook so this:

Set wksZiel = ThisWorkbook.Worksheets.Add()

becomes this:

Set wksZiel = wbkQuelle.Worksheets.Add()

 

[silentwolf]

I guess I am to dumb for this..

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

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

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.

 

[silentwolf]

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]

You should be using:

Set wbkQuelle = appExcel.Workbooks.Open(varPfadDatei)

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