- Private Sub ImportAccess_Click()
- Dim Cela_Cesta As String, Cesta As Variant, Cesta2 As String, F As String
- Dim Radek As Long
- Dim Database As Object
- Dim Rs As Object
- Dim Odkaz As Worksheet
- Dim Sloupec As Integer
- Dim Tabulka As String
- Dim Pripona As String, Znak As String, I As Integer, Poloha As Integer
- Dim Delka As Integer
- 'Spuštění dialogu pro výběr souboru a ověření výběru
- Cesta = Application _
- .GetOpenFilename("Databáze Access (*.mdb), *.mdb,(*.accdb), *.accdb ")
- If Cesta = False Then
- MsgBox "Nic neotevřeno.", vbInformation, "Informace uživateli"
- Exit Sub
- End If
- If Worksheets("Ovladac").Cells(2, 2).Value = "" Then
- MsgBox "Není vyplněn název tabulky pro import", vbCritical, "Chyba!"
- Exit Sub
- End If
- Tabulka = Trim(Worksheets("Ovladac").Cells(2, 2).Value)
- Pripona = Worksheets("Ovladac").Cells(4, 2).Value
- Worksheets("Access").Cells.Delete
- 'Definování umístění složky a jejího názvu
- Delka = Len(Cesta)
- For I = Delka To 1 Step -1
- Znak = Mid(Cesta, I, 1)
- If Znak = "\" Then
- Poloha = I
- Exit For
- End If
- Next I
- Cela_Cesta = Left(Cesta, Poloha) & Pripona
- Cesta2 = Left(Cesta, Poloha)
- Application.ScreenUpdating = False
- F = Dir(Cela_Cesta)
- Radek = 2
- 'Definování odkazu pro výběr dat
- Set Odkaz = Worksheets("Access")
- 'Vytvoření objektové proměnné spustí Access na pozadí
- Dim app As New Access.Application
- 'Otevření zdrojové databáze a vytvoření její objektové proměnné
- On Error GoTo Chyba2
- app.OpenCurrentDatabase Cesta2 & F
- Set Database = app.CurrentDb
- ' Vytvoření recordsetu
- On Error GoTo Chyba
- Set Rs = Database.OpenRecordset(Tabulka)
- 'Zápis názvu polí
- For Sloupec = 0 To Rs.Fields.Count - 1
- Worksheets("Access").Range("A1").Offset(0, Sloupec).Value = _
- Rs.Fields(Sloupec).Name
- Next
- ' Zkopírování vybraných záznamů do sešitu
- Odkaz.Cells(Radek, 1).CopyFromRecordset Rs
- Rs.Close
- 'Přičítání řádků - určení prvního neposaného řádku
- Radek = Cells.CurrentRegion.Rows.Count + 1
- 'Uzavření aktuální databáze
- app.CloseCurrentDatabase
- 'Procházení dalších souborů
- Do
- F = Dir
- If F <> "" Then
- 'Otevření zdrojové databáze a vytvoření její objektové proměnné
- On Error GoTo Chyba2
- app.OpenCurrentDatabase Cesta2 & F
- Set Database = app.CurrentDb
- ' Vytvoření recordsetu
- On Error GoTo Chyba
- Set Rs = Database.OpenRecordset(Tabulka)
- 'Zkopírování vybraných záznamů do sešitu
- Odkaz.Cells(Radek, 1).CopyFromRecordset Rs
- Rs.Close
- 'Přičítání řádků - určení prvního nepopsaného řádku
- Radek = Cells.CurrentRegion.Rows.Count + 1
- If Radek >= 1048576 Then MsgBox "Sešit je již zaplněn.", vbCritical, "Chyba"
- 'Uzavření aktuální databáze
- app.CloseCurrentDatabase
- End If
- Loop While F <> ""
- ' Ukončení Accessu
- app.Quit
- Worksheets("Access").Activate
- Application.ScreenUpdating = True
- Exit Sub
- Chyba:
- MsgBox "Databáze: " & Cesta2 & F & " neobsahuje importovanou tabulku.", vbCritical, "Chyba!"
- Exit Sub
- Chyba2:
- MsgBox "Zřejmě byla vybrána databáze se špatným formátem.", vbCritical, "Chyba!"
- '
- 'Application.ScreenUpdating = True
- '
- End Sub
Věděl by někdo, jak do makra v Excelu dostat dialogové okno Vybrat tabulku z Accessu - jak napsat pro jeho vyvolání kód.
Přes nahrávání maker se mi to nedaří.