Zellwerte aus mehreren Dateien per VBA

[Philipp1344]

Hi Stefan,
Ja, Dateipfad habe ich zweimal eingefügt, bzw. beim ersten mal inkl. exaktem Pfad zur Datei.
Sorry, falls das mit den Dateinamen verwirrend war, darauf habe ich grade nicht geachtet...Dateien sind aber wie im Eingangsthread benannt.

Hier der Code wie von mir "angepasst":

Sub prcX()
   Dim strDatei As String, strLieferant As String, strSachnummer As String
  
   'On Error Resume Next
   'im Unterverzeichnis Dateien bitte anpassen
   strDatei = Dir(ThisWorkbook.Path & "Z:\...\...\...\...\...\...\...\Angebot_Lieferant1_Sachnummer1.xlsx")
   Do While strDatei <> ""
      Workbooks.Open ThisWorkbook.Path & "Z:\...\...\...\...\...\...\...\...\...\" & strDatei
      strLieferant = Split(strDatei, "_")(1)
      strSachnummer = Split(strDatei, "_")(2)
      strSachnummer = Left(strSachnummer, InStr(1, strSachnummer, ".") - 1)
      MsgBox "Die Sachnummer " & strSachnummer & " von dem Lieferanten " & _
      strLieferant & " existiert " & IIf(WorkSheetExists(strSachnummer), "", "nicht ") _
      & " als Tabellenblatt."
      ActiveWorkbook.Close False
      strDatei = Dir()
   Loop
End Sub
Public Function WorkSheetExists(ByVal strName As String) As Boolean
   'On Error Resume Next
   WorkSheetExists = Not ThisWorkbook.Worksheets(strName) Is Nothing
 End Function

Beide "on Error resume next" sind aus-kommentiert (habe zuvor auch nur den ersten aus-kommentiert -> kein Unterschied).
Beide Dateipfade führen in denselben Ordner (ersterer lediglich zur exakten Datei) -> Liegt hier der Fehler?

[Steffl]

Hallo Philipp,

wenn ich mich jetzt genau auf deine Angaben von hier festlege

Struktur sieht so aus:
... Überordner >> Vergleichsdatei.xlsm
                     >> Angebotsordner        >> Angebot 1.xls*
                                                         >> Angebot 2.xls*
                                                         >> Angebot n.xls*

dann müssen die Pfadangaben so lauten

PHP-Code:

Sub prcX()
   Dim strDatei As String, strLieferant As String, strSachnummer As String
   
   'On Error Resume Next
   'im Unterverzeichnis Dateien bitte anpassen
   strDatei = Dir(ThisWorkbook.Path & "\Angebotsordner\*.xls*")
   Do While strDatei <> ""
      Workbooks.Open ThisWorkbook.Path & "\Angebotsordner\" & strDatei
      strLieferant = Split(strDatei, "_")(1)
      strSachnummer = Split(strDatei, "_")(2)
      strSachnummer = Left(strSachnummer, InStr(1, strSachnummer, ".") - 1)
      MsgBox "Die Sachnummer " & strSachnummer & " von dem Lieferanten " & _
      strLieferant & " existiert " & IIf(WorkSheetExists(strSachnummer), "", "nicht ") _
      & " als Tabellenblatt."
      ActiveWorkbook.Close False
      strDatei = Dir()
   Loop
End Sub
Public Function WorkSheetExists(ByVal strName As String) As Boolean
   On Error Resume Next
   WorkSheetExists = Not ThisWorkbook.Worksheets(strName) Is Nothing
 End Function 


[Philipp1344]

Hallo Stefan

...also erstmal super, wie schnell du immer antwortest - Danke!

Leider ändert sich am Fehler "Datei nicht gefunden" nach wie vor nichts.

Vielleicht sitzt das Problem wie so oft auch vor dem Bildschirm...

[Steffl]

Hallo,

dann passen die Pfade nicht. Ein letzte Hilfe von mir.

Gehe in deine Datei, in der das Makro ist

• Gehe in deine Datei, in der das Makro ist
  
• rufe den VBA-Editor auf
  
• lass dir dort mit der Tastenkombination Strg + G das Direktfenster anzeigen
  
• gebe in diesem ?ThisWorkbook.Path ein und drücke die Return-Taste
  
• merke dir was das zurückgegeben wird
  
• mache dasselbe mit irgendeiner Angebotsdatei.
  

Wie sehen jetzt beide Pfade aus?

[Philipp1344]

Pfad Vergleichsdatei (Zieldatei): \\...\H01$\Benutzer\Data\My Documents
Pfad Zieldatei:\\...\H01$\Benutzer\Data\My Documents\Angebote

...absolut identisch bis zum letzten Unterordner
(die ... habe ich hier eingefügt, um nicht firmeninterne Verzeichnisstrukturen preiszugeben)

[Steffl]

Hallo Philipp,

(die ... habe ich hier eingefügt, um nicht firmeninterne Verzeichnisstrukturen preiszugeben)

schon klar, du hast aber schon das letzte Verzeichnis vom meinen vermeintlichen 'Angebotsordner' auf den tatsächlichen 'Angebote' abgeändert

[Philipp1344]

Ja habe ich
...seitdem ich das ganze nun unter meinem lokalen Laufwerk speichere, passiert wieder ....exakt nichts..(bei Klick auf Button/Auslösen des Makros)

Code:

Sub prcX()
  Dim strDatei As String, strLieferant As String, strSachnummer As String
 
  'On Error Resume Next
  'im Unterverzeichnis Dateien bitte anpassen
  strDatei = Dir(ThisWorkbook.Path & "\...\H01$\Benutzer\Data\My Documents\*.xls*")
  Do While strDatei <> ""
     Workbooks.Open ThisWorkbook.Path & "\...\H01$\Benutzer\Data\My Documents\Angebote\" & strDatei
     strLieferant = Split(strDatei, "_")(1)
     strSachnummer = Split(strDatei, "_")(2)
     strSachnummer = Left(strSachnummer, InStr(1, strSachnummer, ".") - 1)
     MsgBox "Die Sachnummer " & strSachnummer & " von dem Lieferanten " & _
     strLieferant & " existiert " & IIf(WorkSheetExists(strSachnummer), "", "nicht ") _
     & " als Tabellenblatt."
     ActiveWorkbook.Close False
     strDatei = Dir()
  Loop
End Sub
Public Function WorkSheetExists(ByVal strName As String) As Boolean
  'On Error Resume Next
  WorkSheetExists = Not ThisWorkbook.Worksheets(strName) Is Nothing
End Function

Hätte nicht gedacht, dass es bereits daran scheitert...

[Steffl]

Hallo Philipp,

ist ja auch klar, wenn Du das immer falsch übernimmst Erinnerst Du dich noch, was als Pfad zurückgegeben wurde? Und Du verbindest das dann nochmal mit einer starren Pfadangeabe.

Code:

Sub prcX()
   Dim strDatei As String, strLieferant As String, strSachnummer As String
  
   'On Error Resume Next
   'im Unterverzeichnis Dateien bitte anpassen
   strDatei = Dir(ThisWorkbook.Path & "\Angebote\*.xls*")
   Do While strDatei <> ""
      Workbooks.Open ThisWorkbook.Path & "\Angebote\" & strDatei
      strLieferant = Split(strDatei, "_")(1)
      strSachnummer = Split(strDatei, "_")(2)
      strSachnummer = Left(strSachnummer, InStr(1, strSachnummer, ".") - 1)
      MsgBox "Die Sachnummer " & strSachnummer & " von dem Lieferanten " & _
      strLieferant & " existiert " & IIf(WorkSheetExists(strSachnummer), "", "nicht ") _
      & " als Tabellenblatt."
      ActiveWorkbook.Close False
      strDatei = Dir()
   Loop
End Sub
Public Function WorkSheetExists(ByVal strName As String) As Boolean
   On Error Resume Next
   WorkSheetExists = Not ThisWorkbook.Worksheets(strName) Is Nothing
End Function

[Philipp1344]

Okay, Fehler gefunden und korrigiert. Bei Klick auf meinen Button wird nun eine meiner Angebotsdateien geöffnet (Angebot_Lieferant1_Sachnummer1.xlsx), die weiteren Angebotsdateien (...Lieferant2_Sachnummer1, ...Lieferant3_Sachnummer1 etc) jedoch nicht. Nach Öffnen der Angebotsdatei erscheint zudem das Info-Fenster "Index außerhalb des gültigen Bereichs". (?????)

Außerdem wäre es jetzt noch extrem nützlich, wenn die ausgewählten Zellbereiche der Angebotsdateien (jeweils E19:E74) durch eben jenen Button dann in meine Zieldatei (in der sich der Button befindet) eingepflegt werden, nach folgendem Schema:

Lieferant1_Sachnummer1: Werte aus E19:E74 in Zieldatei E4:E60

Lieferant2_Sachnummer1: Werte aus E19:E74 in Zieldatei H4:H60

Lieferant3_Sachnummer1: Werte aus E19:E74 in Zieldatei L4:L60

... und so weiter (weitere Lieferanten-Daten jeweils im Abstand von 3 Spalten hinzufügen)

Vielleicht wurde das aus meinem Eingangsthread nicht ganz klar.

Code:

Sub prcX()
  Dim strDatei As String, strLieferant As String, strSachnummer As String
 
  'On Error Resume Next
  'im Unterverzeichnis Dateien bitte anpassen
  strDatei = Dir(ThisWorkbook.Path & "\Angebote\*.xls*")
  Do While strDatei <> ""
     Workbooks.Open ThisWorkbook.Path & "\Angebote\" & strDatei
     strLieferant = Split(strDatei, "_")(1)
     strSachnummer = Split(strDatei, "_")(2)
     strSachnummer = Left(strSachnummer, InStr(1, strSachnummer, ".") - 1)
     MsgBox "Die Sachnummer " & strSachnummer & " von dem Lieferanten " & _
     strLieferant & " existiert " & IIf(WorkSheetExists(strSachnummer), "", "nicht ") _
     & " als Tabellenblatt."
     ActiveWorkbook.Close False
     strDatei = Dir()
  Loop
End Sub
Public Function WorkSheetExists(ByVal strName As String) As Boolean
  'On Error Resume Next
  WorkSheetExists = Not ThisWorkbook.Worksheets(strName) Is Nothing
End Function

[Steffl]

Hallo Philipp,

Nach Öffnen der Angebotsdatei erscheint zudem das Info-Fenster "Index außerhalb des gültigen Bereichs". (?????)

wenn ich mal aus deinen ersten Beitrag zitieren darf

Datei: Angebot_Lieferant1_Sachnummer1
Werte die verglichen, bzw in Vergleichsdatei kopiert werden sollen:E24, E29, E31, E38, E44, ...
in Vergleichsdatei (Tabellenblattname = Sachnummer): D10, D15, D17, D24, D30, ... (Beginnt in anderer Zelle, dann aber in gleicher Zählweise, bzw. Sprüngen "nach unten" wie in Quelldatei)

Datei: Angebot_Lieferant2:Sachnummer1
soll dann exakt gleich in Vergleichsdatei eingefügt werden, jedoch in Spalte H (immer 4 Spalten weiter rechts)

mein Code bezieht sich darauf, dass sich die Sachnummer als Tabellenblattname in deiner Vergleichsdatei befindet. Dem scheint jetzt wohl nicht so zu sein.