Zellwerte aus mehreren Dateien per VBA

[Philipp1344]

Hallo Stefan...leider richtig

[Steffl]

Hallo Philipp,

Code:

Sub prcX()
   Dim strDatei As String
   Dim lngSpalte As Long
  
   'On Error Resume Next
   'Eintrag in Spalte E
   lngSpalte = 5
   'im Unterverzeichnis Dateien bitte anpassen
   strDatei = Dir(ThisWorkbook.Path & "\Angebote\*.xls*")
   Do While strDatei <> ""
      Workbooks.Open ThisWorkbook.Path & "\Angebote\" & strDatei
      ActiveWorkbook.Worksheets(1).Range("E19:E74").Copy ThisWorkbook.Worksheets(1).Cells(4, lngSpalte).Value
      lngSpalte = lngSpalte + 3
      ActiveWorkbook.Close False
      strDatei = Dir()
   Loop
End Sub

der Code kopiert jeweils aus dem ersten Tabellenblatt der Angebotsdateien in das erste Tabellenblatt der Vergleichsdatei. In der Vergleichsdatei jeweils versetzt um drei Spalten beginnend mit der Spalte E. Ich habe mich bei den Bereichsangaben an deinen Angaben aus dem Beitrag 19 gehalten, die aber von denen aus dem Startbeitrag abweichen.

[Philipp1344]

Hallo Stefan,

leider spuckt Excel mir bei Ausführung deines letzten Codes die (X) Fehlermeldung "400" aus. Ohne weitere Infos.
Habe versucht den Code weitestmöglich nachzuvollziehen, was mir bedingt gelungen ist.

Ich finde darin keinen Befehl, der mir die Werte auch in meine Zieldatei einfügt....lediglich den copy-befehl

Grüße Philipp

[Steffl]

Hallo Philipp,

in welcher Codezeile kommt der Fehler?

[Philipp1344]

Die Codezeile wird mir nicht angezeigt, die Meldung erscheint direkt nachdem sich die Angebotsdatei (Quelldatei) öffnet (was ja eigentlich gar nicht notwendig ist, da ja nur die Werte übernommen werden sollen). Hmmm...

[Steffl]

Hallo Philipp,

Die Codezeile wird mir nicht angezeigt, die Meldung erscheint direkt nachdem sich die Angebotsdatei (Quelldatei) öffnet

im Meldungsfenster sollten auch ein paar Buttons sein mit den Bezeichnungen Beenden bzw. Debuggen. Klicke da mal auf Debuggen. Ist jetzt eine Zeile markiert? Wenn ja, welche?

.... (was ja eigentlich gar nicht notwendig ist, da ja nur die Werte übernommen werden sollen). Hmmm...

auch Hmmm. Es gibt zwar eine Funktion von Thomas Ramel, die kann aus geschlossenen Dateien Daten auslesen aber ob man das auf deinen Fall umstricken kann. Weis ich nicht.

[Philipp1344]

Hallo Stefan, habe das Makro jetzt mal aus dem Editor gestartet und nicht per Button. Nachdem sich die Quelldatei öffnet, erscheint nun im Editor die Meldung "Die Copy-Methode des Range Objektes konnte nicht ausgeführt werden".
Eine Debug-Button gibt es aber nicht...

[Steffl]

Hallo Philipp,

da ich deine Dateien nicht kenne, wäre das alles nur ein Ratespiel was der Grund ist. Ich habe mal nach der angesprochenen Funktion von Thomas Ramel gesucht und versucht, den Code anzupassen. Mangels Testmöglichkeit ist dies ungeprüft.

Code:

Sub prcX()
   Dim strDatei As String
   Dim lngSpalte As Long
  
   'On Error Resume Next
   'Eintrag in Spalte E
   lngSpalte = 5
   'im Unterverzeichnis Dateien bitte anpassen
   strDatei = Dir(ThisWorkbook.Path & "\Angebote\*.xls*")
   Do While strDatei <> ""
      If GetDataClosedWB(ThisWorkbook.Path & "\Angebote\", _
         strDatei, "Tabelle1", "E19:E74", _
         ThisWorkbook.Worksheets(1).Cells(4, lngSpalte)) Then
         lngSpalte = lngSpalte + 3
      End If
      strDatei = Dir()
   Loop
End Sub
Public Function GetDataClosedWB(SourcePath As String, _
                                 SourceFile As String, _
                                 sourceSheet As String, _
                                 SourceRange As String, _
                                 TargetRange As Range) As Boolean

'Holt einen Bereich aus einer _geschlossenen_ Arbeitsmappe
'Nur in VBA zu verwenden; nicht aus einer Tabellenzelle heraus
'© t.ramel@mvps.org

Dim strQuelle       As String
Dim Zeilen          As Long
Dim Spalten         As Long   'Byte habe ich in Long geändert

    On Error GoTo InvalidInput

    strQuelle = "'" & SourcePath & "[" & SourceFile & "]" & _
                sourceSheet & "'!" & _
                Range(SourceRange).Cells(1, 1).Address(0, 0)

    Zeilen = Range(SourceRange).Rows.Count
    Spalten = Range(SourceRange).Columns.Count

    With TargetRange.Cells(1, 1).Resize(Zeilen, Spalten)
       .Formula = "=IF(" & strQuelle & "="""",""""," & strQuelle & ")"
       .Value = .Value
    End With

    GetDataClosedWB = True
    Exit Function

InvalidInput:
    MsgBox "Die Quelldatei oder der Quellbereich ist ungültig!", _
           vbExclamation, "Get data from closed Workbook"
    GetDataClosedWB = False
End Function

[Philipp1344]

Hallo Stefan,

ein kleiner Fortschritt, immerhin! Danke!
Allerdings kopiert er mir jetzt die Werte dreimal in die Zieldatei. Ich muss auch noch ein paar Zell-Zuordnungen anpassen. Ich probiere mal selbst und melde mich wieder! Gff. dann auch mal mit einer Beispieldatei.

Grüße,
Philipp

[schauan]

Hallöchen,

mal zu #22

Wäre statt
ActiveWorkbook.Worksheets(1).Range("E19:E74").Copy ThisWorkbook.Worksheets(1).Cells(4, lngSpalte).Value

nicht
ActiveWorkbook.Worksheets(1).Range("E19:E74").Copy ThisWorkbook.Worksheets(1).Cells(4, lngSpalte)

besser?