Werte aus versch. geschl. Dateien

Hallo miteinander,
ich muss zugeben, dass ich komplett neu hier bin und in VBA kaum bis gar keine Erfahrungen habe :-(
Ich habe folgendes Problem:
Ich habe auf dem Server in verschiedenen Ordnern Excel-Dateien liegen, aus denen ich Werte benötige, die in einer separaten Übersichtstabelle aufgeführt werden sollen. Diese Dateien sollen hierzu nicht geöffnet werden, da dies zu lange dauern würde und auch Unmengen von Dateien öffnen würde. Das untenstehende Makro funktioniert dahingehend dass ich schon Mal Werte aus einer Datei herausholen und in der separaten Tabelle zeigen kann. Jetzt habe ich allerdings folgende Probleme:
- in dem Makro kann nur eine einzige Datei angesprochen werden und deren Werte eingefügt werden
- zudem werden die Werte in den gleichen Spalten und Zeilen eingefügt, wo sie auch in der Quelldatei liegen
Was ich gerne hätte:
1. die in dem folgenden Makro fettgedruckten Dinge sollten aus einer Liste eigenständig verwendet werden. Der Link und der Dateiname stehen also z.Bsp. von B1 bis B10 bzw. C1 bis C10. in A1 bis A10 stehen die Projektnamen (Projekt1, Projekt2,usw.).
2. die abgefragten entsprechenden Werte der einzelnen Projekt-Datei sollen nun untereinander folgendermaßen Aufgelistet werden (z.Bsp. ab Zeile 15):
Projekt1
WertA24 WertB24 ... WertX24
WertA25 WertB25 ...
.... .... ...
(Leerzeile)
Projekt 2
WertA24 WertB24 ... WertX24
WertA25 WertB25 ...
.... .... ...
(Leerzeile)
usw.
Wie muss das Makro dahingehend dann aussehen, damit man das realisieren kann? Ich versuche wirklich in VBA rein zu kommen aber ohne Vorlage komme ich da absolut nicht weiter.
Kann mir hier jemand weiterhelfen?
Schon Mal Danke im Voraus für die Bemühungen.
Hier das momentan vorhandene Makro:

Sub Bereich_auslesen()
'** Dimensionierung der Variablen
Dim pfad As String, datei As String, blatt As String, bereich As Range, zelle As Object
'** Angaben zur auszulesenden Zelle
pfad = "O:\Groupshares\Projekt 1\04_Subvendors"
datei = "QC_Projekt1.xlsm"
blatt = "Project Overview"
Set bereich = Range("A24:X35")
'** Bereich auslesen
For Each zelle In bereich
'** Zellen umwandeln
zelle = zelle.Address(False, False)
'** Eintragen in Bereich
ActiveSheet.Cells(zelle.Row, zelle.Column).Value = GetValue(pfad, datei, blatt, zelle)
Next zelle
End Sub

Gruß
Markus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc][+][-] Option Explicit Sub Bereich_auslesen() '** Dimensionierung der Variablen Dim sPfad As String, sDatei As String, sBlatt As String, rBereich As Range Dim Zelle As Object, sProjektname As String Dim iZeile As Long, iOutZeile As Long, OldRow As Long With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With iOutZeile = 14 With ThisWorkbook.Sheets("Liste") If ActiveSheet.Name = .Name Then Exit Sub For iZeile = 15 To 25 iOutZeile = iOutZeile + 1 sProjektname = .Cells(iZeile, "A").Value If sProjektname <> "" Then sPfad = .Cells(iZeile, "B").Value If Right$(sPfad, 1) <> "\" Then sPfad = sPfad & "\" sDatei = .Cells(iZeile, "C").Value sBlatt = .Cells(iZeile, "D").Value '** Bereich auslesen ActiveSheet.Cells(iOutZeile, "A").Value = sProjektname Set rBereich = Range("A24:X35") OldRow = 0 For Each Zelle In rBereich If Zelle.Row > OldRow Then OldRow = Zelle.Row iOutZeile = iOutZeile + 1 End If ActiveSheet.Cells(iOutZeile, Zelle.Column).Value _ = GetValue(sPfad, sDatei, sBlatt, Zelle) Next Zelle iOutZeile = iOutZeile + 1 End If Next iZeile End With With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationAutomatic End With MsgBox "Fertig", vbInformation, "Daten einlesen" End Sub

Code: [Cc][+][-] Option Explicit Sub Bereich_auslesen() '** Dimensionierung der Variablen Dim sPfad As String, sDatei As String, sBlatt As String, rBereich As Range Dim Zelle As Object, sProjektname As String Dim iZeile As Long, iOutZeile As Long, OldRow As Long With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With iOutZeile = 14 With ThisWorkbook.Sheets("Liste") If ActiveSheet.Name = .Name Then Exit Sub For iZeile = 15 To 25 iOutZeile = iOutZeile + 1 sProjektname = .Cells(iZeile, "A").Value If sProjektname <> "" Then sPfad = .Cells(iZeile, "B").Value If Right$(sPfad, 1) <> "\" Then sPfad = sPfad & "\" sDatei = .Cells(iZeile, "C").Value sBlatt = .Cells(iZeile, "D").Value '** Bereich auslesen ActiveSheet.Cells(iOutZeile, "A").Value = sProjektname Set rBereich = Range("A24:X35") OldRow = 0 For Each Zelle In rBereich If Zelle.Row > OldRow Then OldRow = Zelle.Row iOutZeile = iOutZeile + 1 End If ActiveSheet.Cells(iOutZeile, Zelle.Column).Value _ = GetValue(sPfad, sDatei, sBlatt, Zelle) Next Zelle iOutZeile = iOutZeile + 1 End If Next iZeile End With With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With MsgBox "Fertig", vbInformation, "Daten einlesen" End Sub

Code: [Cc] Private Function GetValue(ByVal sPath As String, ByVal sFile As String, _ ByVal sSheet As String, oTarget As Object) As Variant 'Einen Wert aus einer Datei holen On Error GoTo ErrorHandler If Right$(sPath, 1) <> "\" Then sPath = sPath & "\" GetValue = ExecuteExcel4Macro("'" & sPath & "[" & sFile & "]" & sSheet & "'!" _ & oTarget.Range("A1").Address(, , xlR1C1)) Exit Function ErrorHandler: GetValue = CVErr(xlErrRef) End Function

Private Function GetValue(pfad, datei, blatt, Zelle) '** Daten aus geschlossener Arbeitsmappe auslesen '*** Dimensionierung der Variablen Dim arg As String 'Sicherstellen, dass das datei vorhanden ist If Right(pfad, 1) "\" Then pfad = pfad & "\" If Dir(pfad & datei) = "" Then GetValue = "datei Not Found" Exit Function End If '** Das Argument erstellen arg = "'" & pfad & "[" & datei & "]" & blatt & "'!" & Range(Zelle).Range("A1").Address(, , _ xlR1C1) '** Auslesen über Excel4Macro GetValue = ExecuteExcel4Macro(arg) End Function

Code: [Cc][+][-] Option Explicit Sub Bereich_auslesen() '** Dimensionierung der Variablen Dim sPfad As String, sDatei As String, sBlatt As String, rBereich As Range Dim Zelle As Object, sProjektname As String Dim iZeile As Long, iOutZeile As Long, OldRow As Long With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With iOutZeile = 14 With ThisWorkbook.Sheets("Liste") If ActiveSheet.Name = .Name Then Exit Sub For iZeile = 15 To 25 iOutZeile = iOutZeile + 1 sProjektname = .Cells(iZeile, "A").value If sProjektname <> "" Then sPfad = .Cells(iZeile, "B").value If Right$(sPfad, 1) <> "\" Then sPfad = sPfad & "\" sDatei = .Cells(iZeile, "C").value sBlatt = .Cells(iZeile, "D").value '** Bereich auslesen ActiveSheet.Cells(iOutZeile, "A").value = sProjektname Set rBereich = Range("A24:X35") OldRow = 0 For Each Zelle In rBereich If Zelle.Row > OldRow Then OldRow = Zelle.Row iOutZeile = iOutZeile + 1 End If ActiveSheet.Cells(iOutZeile, Zelle.Column).value _ = GetValue(sPfad, sDatei, sBlatt, Zelle) Next Zelle iOutZeile = iOutZeile + 1 End If Next iZeile End With With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationAutomatic End With MsgBox "Fertig", vbInformation, "Daten einlesen" End Sub Private Function GetValue(ByVal sPath As String, ByVal sFile As String, _ ByVal sSheet As String, oTarget As Object) As Variant 'Einen Wert aus einer Datei holen On Error GoTo ErrorHandler If Right$(sPath, 1) <> "\" Then sPath = sPath & "\" GetValue = ExecuteExcel4Macro("'" & sPath & "[" & sFile & "]" & sSheet & "'!" _ & oTarget.Range("A1").Address(, , xlR1C1)) Exit Function ErrorHandler: GetValue = CVErr(xlErrRef) End Function

Hallo Markus,
konnte nicht früher antworten.
Nein es liegt nicht an der Version und auch nicht an der Erweiterung .xlsm.
Ich hatte dem Makro verboten, in das Blatt Liste zu schreiben sondern nur ins aktive Blatt. Dein Button befindet sich aber auf diesem Blatt und damit ist das Blatt Liste das aktive Blatt.
Ich habe das Makro jetzt geändert. Du musst dann allerdings einen Blattnamen vorgeben. Ich habe jetzt mal "Daten" genommen.
Noch etwas: Dein altes Makro aus Modul1 erwartet als Bereichsangabe einen String. Im Modul2 wird dort aber ein Range erwartet. Ich hatte mein GetValue-Makro extra deswegen umgeschrieben.
Sprich: Dein altes GetValue-Makro kann im neuen Makro im Modul2 nicht funktionieren.
Daten übertragen.xlsm
viele Grüße
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

Werte aus versch. geschl. Dateien

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread