Docmd.transferspreadsheet Fonksiyon Olarak Çağırma

1 2 3 4 5 6 7 8 9 10 11 12 13
16/02/2020, 14:37

accessman

şöyle bir kod var bunu bizdeki koda nasıl uyarlayabiliriz.


' 1. get the file name
' 2. open it
' 3. import the first sheet
' 4. check if there is more sheets, and import them as well.

' 1. loop over all tables
' 2. for each file - import the data in loop - for each sheet
' 3. pre-req - all sheets has to have headers with correct columns


Private Sub btnImportFromExcel_Click()
    Const FUNC_NAME As String = MOD_NAME & "." & "btnImportFromExcel_Click"
    On Error GoTo Sub_err

    Dim rsFileToImport As Recordset
    Dim wbFile As Workbook
    Dim sFileName As String
    Dim sFilePath As String
    Dim sTableName As String
    Dim i As Long
    Dim sMissingFiles As String

    Set rsFileToImport = GetRS("Q_ImportRelevant")

    While Not (rsFileToImport.EOF)
        ' Open the file

        sFileName = rsFileToImport("sTableName")
        sFilePath = Me.txtFilesPath & "\" & sFileName
        If FileExists(sFilePath) Then

            Set wbFile = Workbooks.Open(sFilePath)
            sTableName = Left(sFileName, Len(sFileName) - 4)

            ' Import and create the table
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, sTableName, sFilePath, True, "Sheet0!"
            SetStatusBar "Importing: " & sFileName & ", Sheet0"

            ' Import data from the rest of the sheets.
            i = 0
            For i = 1 To wbFile.Sheets.Count - 1
                DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, sTableName, sFilePath, True, "Sheet" & i & "!"
                SetStatusBar "Importing: " & sFileName & ", Sheet" & i & "/" & wbFile.Sheets.Count - 1
            Next i
        Else
            sMissingFiles = sMissingFiles & vbNewLine & sFileName
        End If

        wbFile.Close
        SetStatusBar "Import " & sFileName & " Finished"

        rsFileToImport.MoveNext
    Wend

    MsgBox "Missing files:" & sMissingFiles
    SetStatusBar "Import Finish"

Sub_exit:
    Exit Sub
Sub_err:
    ErrMsgBox Err.Number, FUNC_NAME & "[" & Erl & "]" & "\" & Err.Source, Err.Description & vbNewLine & sFileName & " (sheet" & i & ")"
    Resume Sub_exit
End Sub
16/02/2020, 14:41

berduş

sayın accessman açık ve net olarak ne istediğinizi, amacınızı açıklar mısınız?
16/02/2020, 14:52

feraz

Sayın berduş hocam accessman hocamız sizin açtığınız excelden veri alma konusuna yazmıştı orda anlatmıştı.Dedim orda ayrı konu açıp örnek ekleyin diye.
Yine accessman hocamız herzamanki gibi inat ediyor dosya eklememekle Bu konuda heralde 20 sayfaya ulaşır bu şekilde
16/02/2020, 14:53

accessman

amacım şu bir fonksiyona bağlamak istediğim 
excel dosya yolunu, sayfa adını range aralığını  ve Access tablo adını göndereyim
fonsiyon da bana tablo oluşturunca tablo adını veya oluşturup oluşturamadığını bildirsin
16/02/2020, 14:55

accessman

ama bu genel bir soru değil mi zaten olan bir kodu fonsiyon haline getirip argument gönderip result almak
böylece istediğimiz yerden istediğimiz Excel ve tablo için kullanabilmek
16/02/2020, 15:00

berduş

O zaman 8. Mesajdaki koda ne gerek var. Oluşturulup oluşturulmadığını kontrol etmek için daha önce belirttiğim count yada Dlookup kullanilir
1 2 3 4 5 6 7 8 9 10 11 12 13