wie lässt sich das Makro unten folgend so anpassen, damit ich nicht immer den Pfad auswählen muss, wo die Dateien liegen? Das Makro soll immer auf den gleichen Ordner auf dem Server zugreifen und sich von dort die benötigen Informatioen holen.
Welche schnelleren Möglichkeiten gibt es noch sich Werte aus anderen Dateien zu holen? Das Makro öffnet eine Datei nach und nach und liest immer aus der gleichen Zeile aus und speichert die Werte in der Tabelle X ab. Die Prozedur dauert etwas, je nach dem wie viele Daeien auszulesen sind. Lässt sich eine Verknüpfung herstellen, durch die ich sofort beim eintragen eines Wertes die Information in meiner Tanelle X erhalte ohne ein Makro dazwischen schalten zu muss?
Sub DatenImportieren()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Auslesen der einzelnen Fahrzeugdateien
Dim sVerzeichnis$, sDatei$
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim ZeileZ&, FileCount&
Dim Zelle As Range
Const StartZelle$ = "K3" '1. Auszulesende Zelle in Tabelle 1
Const Schritt& = 1 'Spaltenabstand der auszulesenden Zellen
On Error GoTo Fehler
'Suchverzeichnis auswahlen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit zu durchsuchenden Dateien wählen"
.ButtonName = "Auswählen"
If .Show = -1 Then
sVerzeichnis = .SelectedItems(1)
sDatei = Dir(sVerzeichnis & Application.PathSeparator & "*.xl*")
If sDatei "" Then
'neue Datei mit einem Tabellenblatt für Ergebnisdaten erstellen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
'Zieltabellenblatt Objektvariable zuweisen
Set wksZiel = wbZiel.Worksheets(1)
ZeileZ = 1
With wksZiel
'Titelzeile ausfüllen
.Cells(ZeileZ, 1) = "Info"
.Cells(ZeileZ, 2) = "Status offene Punkte"
.Cells(ZeileZ, 3) = "Dateiname"
End With
End If
Application.ScreenUpdating = False
Do Until sDatei = ""
FileCount = FileCount + 1
Application.StatusBar = "Datei, laufende Nr. " & FileCount & " wird bearbeitet."
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open( _
Filename:=sVerzeichnis & Application.PathSeparator & sDatei, _
ReadOnly:=True)
'Tabelle1 Objektvariable zuweisen
Set wksQuelle = wbQuelle.Worksheets(1)
'Werte aus Blatt 1 auslesen
Set Zelle = wksQuelle.Range(StartZelle)
Do Until IsEmpty(Zelle)
If Zelle.Value 0 Then
ZeileZ = ZeileZ + 1
With wksZiel
'Info aus Zeile 1 eintragen
.Cells(ZeileZ, 1) = wksQuelle.Cells(1, Zelle.Column).Value
'Status offene Punkte
.Cells(ZeileZ, 2) = Zelle.Value
'Dateiname eintragen
.Cells(ZeileZ, 3) = sDatei 'gespeicherter Dateiname
' .Cells(ZeileZ, 3) = wksQuelle.Cells(1, 1).Value 'Dateinem in A1 des Quellblatts
End With
End If
'Nächste Zelle setzen
Set Zelle = Zelle.Offset(0, Schritt)
Loop
wbQuelle.Close SaveChanges:=False
Set wksQuelle = Nothing
Set wbQuelle = Nothing
sDatei = Dir
Loop
Application.ScreenUpdating = True
'MsgBox "Alle Dateien ausgelesen" (hier mit dem ' ausgeblendet, da nutzlos)
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing Then wbQuelle.Close SaveChanges:=False
End Select
End With
Set wbZiel = Nothing
Set wbQuelle = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub