Zugriff auf externe Daten

Sub Import_ISR() Dim actual_month As Date 'Vorhandene Daten im Ziel löschen 'ActiveWorkbook.Worksheets("ISR Import Database").AutoFilter.Sort.SortFields. _ Clear If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData Range("A3", ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete Range("A3").Select 'Daten von Quelle kopieren und im Ziel einfügen Windows("export.XLSX").Activate Range("A2", ActiveCell.SpecialCells(xlLastCell)).Copy Windows("SQ_BSC-Overview__FY18.xlsm").Activate Range("A3").Select ActiveSheet.Paste actual_month = DateSerial(Year(Now), Month(Now), 1) ActiveWorkbook.Worksheets("ISR Import Database").Range("A2").AutoFilter Field:=9, Criteria1:= _ "01.03.2017", Operator:=xlAnd End Sub

Sub Daten_aktualisieren2() ' Pfad Variable definieren Dim strQuelle As String strQuelle = Worksheets("ISR Import Database").Cells(1, 11).Text If Dir(strQuelle) = "" Then MsgBox "Datei nicht gefunden!", vbExclamation, "Hinweis" Exit Sub End If ' Daten_aktualisieren Makro ActiveSheet.Range("A3").Select 'Sheets("ISR Import Database").Select With ActiveWorkbook.Connections("export Sheet1$").OLEDBConnection .BackgroundQuery = True .CommandText = Array("Sheet1$") .CommandType = xlCmdTable .Connection = _ Array("OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=" _ _ & strQuelle & ";Mode=Share Deny Write;Extended Properties=""HDR=YES;"";Jet OLEDB:System _ database="""";Jet OLEDB:Re", _ "gistry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=37;Jet OLEDB: _ Database Locking Mode=0;Jet OLEDB:Global Partia", _ "l Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=""""; _ Jet OLEDB:Create System Database=False;Jet ", _ "OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB: _ Compact Without Replica Repair=False;Jet OLE", _ "DB:SFP=False;Jet OLEDB:Support Complex Data=False;Jet OLEDB:Bypass UserInfo Validation= _ False;Jet OLEDB:Limited DB Caching=False;", _ "Jet OLEDB:Bypass ChoiceField Validation=False") .RefreshOnFileOpen = False .SavePassword = False .SourceConnectionFile = "" .SourceDataFile = strQuelle .ServerCredentialsMethod = xlCredentialsMethodIntegrated .AlwaysUseConnectionFile = False End With With ActiveWorkbook.Connections("export Sheet1$") .Name = "export Sheet1$" .Description = "" End With ActiveWorkbook.Connections("export Sheet1$").Refresh End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Ich glaube, ich habe hier eine bessere Ausgangsbasis gefunden um die richtige Datei zu suchen:

Sub DatenSuchen()
'Sucht in den Matrix_Design-Dateien nach einem Suchbegriff und
'kopiert Daten in das Zielblatt
Dim Suchbegriff As String
Dim wbAktiv As Workbook, wksAktiv As Worksheet
Dim wksZiel As Worksheet
Dim wbQuelle As Workbook, wksQuelle As Worksheet, strWb As String, strWks As String
Dim ZelleGefunden As Range, Bereichdaten As Range
Dim varVerzeichnisQuelle
Dim ZelleSuchbegriff As Range
On Error GoTo Fehler
Set wbAktiv = ActiveWorkbook
Set wksAktiv = ActiveSheet
'Tabelle in die die Daten kopiert werden sollen
Set wksZiel = wbAktiv.Worksheets("ISR Import Database")
Set ZelleSuchbegriff = wksAktiv.Range("G2") ' Selection oder auch feste Zelladresse:   _
wksAktiv.Range("C8")
Suchbegriff = ZelleSuchbegriff.Value
'Quell-Dateinamen und Blattnamen ermitteln
If InStr(1, Suchbegriff, "d") > 0 Then
strWb = "Matrix_Design" & Mid(Suchbegriff, InStr(1, Suchbegriff, "d") + 1, 1)
strWks = "design" & Mid(Suchbegriff, InStr(1, Suchbegriff, "d") + 1, 1)
Else
MsgBox "Buchstabe ""d"" nicht im Suchbegriff """ & Suchbegriff & """ enthalten."
GoTo Ende
End If
'Verzeichnis mit den 5 Quelldateien wählen - als festen Wert vorgeben
'varVerzeichnisQuelle = "C:\Lokale daten\Test"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte Ordner mit den 5 Datendateien wählen und OK"
If .Show  False Then
varVerzeichnisQuelle = .SelectedItems(1)
Else
GoTo Ende
End If
End With
Application.ScreenUpdating = False
'Prüfen, ob Datei im gewählten verzeichnis
With Application
strWb = Dir(varVerzeichnisQuelle & .PathSeparator & strWb & ".xl*")
If strWb  "" Then
'Quelldatei öffnen
Set wbQuelle = .Workbooks.Open(Filename:=varVerzeichnisQuelle _
& .PathSeparator & strWb, ReadOnly:=True)
'Quelltabellenblatt setzen
Set wksQuelle = wbQuelle.Worksheets(strWks)
Else
MsgBox "Quelldatei """ & strWb & ".xl*"" im Verzeichnis """ & _
varVerzeichnisQuelle & """ nicht gefunden!"
GoTo Ende
End If
End With
'Suchbegriff suchen
Set ZelleGefunden = wksQuelle.Cells.Find(What:=Suchbegriff, LookIn:=xlValues, _
lookat:=xlWhole)
If ZelleGefunden Is Nothing Then
MsgBox "Suchbegriff""" & Suchbegriff & """ in Datei """ & _
wbQuelle.Name & """, Blatt """ & wksQuelle.Name & """ nicht gefunden!"
GoTo Ende
Else
With wksQuelle
'Von Fundstelle Bereich 1 Spalte nach links, 1 Zeile nach unten bis _
zur nächsten Leerzeile unterhalb der Fundstelle merken
Set Bereichdaten = .Range(ZelleGefunden.Offset(1, -1), ZelleGefunden.End(xlDown))
End With
'gefundene Daten in die Zieltabelle kopieren.
With wksZiel
.Visible = xlSheetVisible 'Zieltabelle einblenden
'Altdaten im Blatt löschen
.Range(.Cells(2, 1), .Cells(2, 2).End(xlDown)).ClearContents
'Daten Kopieren
Bereichdaten.Copy Destination:=.Cells(2, 1)
End With
'Quelle wieder schliessen
wbQuelle.Close savechanges:=False
Set wbQuelle = Nothing
End If
Ende:
Fehler:
Application.ScreenUpdating = True
With Err
If .Number  0 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End If
End With
'Objektvariablen zurücksetzen
Set wbAktiv = Nothing: Set wksAktiv = Nothing
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
Set wbQuelle = Nothing
Set wksZiel = Nothing
Set wbQuelle = Nothing: Set wksQuelle = Nothing
Set ZelleGefunden = Nothing: Set Bereichdaten = Nothing
End Sub

In meinem Fall ist der Dateiname nicht bekannt, sondern nur der Pfad (L:/temp/) - die Daten befinden sich jedoch immer im "Sheet1" und die richtige Datei ist gefunden, wenn der Text der Zelle A1 ident mit meiner Arbeitsmappe (Blatt "ISR Import Database") ist.
Falls sich jemand um mein Anliegen annimmt, vielen Dank!!!
Lg,
Chrisi

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread