Zellwerte aus mehreren Dateien per VBA

[schauan]

Hier mal der komplette Code, mit dem variablen Pfad:

Code:

Sub prcX()
  Dim strDatei As String
  Dim lngSpalte As Long
  Dim lngC As Long
  Dim vntQuelle As Variant
  Dim vntZiel As Variant
  Dim vntVersatz As Variant
  Dim iCnt%, iCut%, strPfad$
  For iCnt = 1 To 100 'mal auf maximal 100 Dateien beschraenkt
    If Cells(iCnt, 9).Value = "" Then Exit For
    'im Unterverzeichnis Dateien bitte anpassen
    strDatei = Cells(iCnt, 9).Value
    iCut = InStrRev(strDatei, "\")
    strPfad = Left(strDatei, iCut)  'Falls der Pfad gebraucht wird
    strDatei = Mid(strDatei, iCut + 1)
    'On Error Resume Next
    'Eintrag in Spalte E
    vntQuelle = Array("E19:E74", "G8", "G9", "G10")
    vntZiel = Array(5, 3, 2, 1)
    vntVersatz = Array(-1, -1, 1, -1)
    lngSpalte = 4
    'im Unterverzeichnis Dateien bitte anpassen
    'strDatei = Dir(ThisWorkbook.Path & "\PBDs\*.xls*")
    'Do While strDatei <> ""
       For lngC = 0 To UBound(vntQuelle)
          If GetDataClosedWB(strPfad, _
             strDatei, "Tabelle1", CStr(vntQuelle(lngC)), _
             ThisWorkbook.Worksheets(1).Cells(vntZiel(lngC), lngSpalte).Offset(, vntVersatz(lngC))) Then
             If lngC = UBound(vntQuelle) Then lngSpalte = lngSpalte + 4
          End If
       Next lngC
    '   strDatei = Dir()
    'Loop
  Next iCnt
End Sub

[Philipp1344]

Hi schauan,

danke dir für die Hilfe. Den Code hab ich so drin. Was mir nicht klar ist, ist was du in deiner ersten Antwrot mit "brauchst ihn aus Spalte I" meinst

Ich habe jetzt mal mit meiner Userform die Dateipfade in Spalte I meiner Zieldatei gezogen, glaube aber nicht, dass das das ist was du mit sagen wolltest? Es tut sich nämlich nichts...hmmm.

Ergänzende Info (falls es irgendwie helfen sollte): Ich habe in meiner Datei jetzt zwei Buttons:
1. "Dateiauswahl" mein Userform für drag&drop
2. "einpflegen" um die Zellbereiche dieser Dateien in meine Übersicht zu kopieren.

Edit:
Was für mein Verständnis nach wie vor fehlt, ist eine Zuordnung des ersten zum zweiten Makros. Sprich, die Info, woher sich das Makro hinter meinem 2. Button die Dateien nun die Dateipfade holt? Aktuell hängt die Zellen, in der die Dateipfade ausgegeben werden noch davon ab, welche Zelle zuletzt markiert war...

Code:

Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Long
  If Data.GetFormat(vbCFFiles) Then
     s = ActiveCell.Column
     z = Cells(ActiveSheet.Rows.Count, s).End(xlUp).Row
     If Not (IsEmpty(Cells(z, s))) Then z = z + 1
     For i = 1 To Data.Files.Count
         ActiveSheet.Cells(z, s).Hyperlinks.Add ActiveSheet.Cells(z, s), Data.Files(1)
         z = z + 1
     Next
  End If
End Sub

 Das ist also auch ein Problem, dass es zu lösen gilt (und das ich leider auch unfähig zu lösen bin )...

[schauan]

Hallöchen,

wenn ich Dein Userform laufen lasse, werden mir die Dateinamen einschl. Pfad in Spalte I eingetragen - dachte ich zumindest Muss die Spalte H sein, also 8 bzw. statt
Cells(iCnt, 9)
dann
Cells(iCnt, 8)

(2 Stellen im Code)


Hast Du bei Dir eigentlich schon den Fehler mit den mehreren Files rausgenommen? In Deinem geposteten Code war er nämlich noch drin:
… Data.Files(1)

Statt der 1 muss hier ein i rein.

[Philipp1344]

Hi, habe deine Anmerkungen korrigiert..meine Testdatei ist leider etwas zu groß zum anhängen.
Leider passiert aktuell nichts wenn ich meine ausgewählten Dateien einpflegen möchte

Meine Fehler-Aufspür-Skills sind leider mangels VBA-Kenntnis ebenfalls sehr beschränkt

alle Codes nochmal:

Userform:

Code:

Option Explicit

Const vbDropEffectNone = 0
Const vbDropEffectCopy = 1
Const vbDropEffectMove = 2

Const vbCFFiles = 15
Private Sub bAbbrechen_Click()
  Unload Me
End Sub
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Long
  If Data.GetFormat(vbCFFiles) Then
     s = ActiveCell.Column
     z = Cells(ActiveSheet.Rows.Count, s).End(xlUp).Row
     If Not (IsEmpty(Cells(z, s))) Then z = z + 1
     For i = 1 To Data.Files.Count
         ActiveSheet.Cells(z, s).Hyperlinks.Add ActiveSheet.Cells(z, s), Data.Files(i)
         z = z + 1
     Next
  End If
End Sub
Private Sub ListView1_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
   Effect = vbDropEffectCopy
End Sub

Private Sub UserForm_Click()

End Sub

Dateien einpflegen:

Code:

Sub prcX()
 Dim strDatei As String
 Dim lngSpalte As Long
 Dim lngC As Long
 Dim vntQuelle As Variant
 Dim vntZiel As Variant
 Dim vntVersatz As Variant
 Dim iCnt%, iCut%, strPfad$
 For iCnt = 1 To 100 'mal auf maximal 100 Dateien beschraenkt
   If Cells(iCnt, 8).Value = "" Then Exit For
   'im Unterverzeichnis Dateien bitte anpassen
   strDatei = Cells(iCnt, 8).Value
   iCut = InStrRev(strDatei, "\")
   strPfad = Left(strDatei, iCut)  'Falls der Pfad gebraucht wird
   strDatei = Mid(strDatei, iCut + 1)
   'On Error Resume Next
   'Eintrag in Spalte E
   vntQuelle = Array("E19:E74", "G8", "G9", "G10")
   vntZiel = Array(5, 3, 2, 1)
   vntVersatz = Array(-1, -1, 1, -1)
   lngSpalte = 4
   'im Unterverzeichnis Dateien bitte anpassen
   'strDatei = Dir(ThisWorkbook.Path & "\PBDs\*.xls*")
   'Do While strDatei <> ""
      For lngC = 0 To UBound(vntQuelle)
         If GetDataClosedWB(strPfad, _
            strDatei, "Tabelle1", CStr(vntQuelle(lngC)), _
            ThisWorkbook.Worksheets(1).Cells(vntZiel(lngC), lngSpalte).Offset(, vntVersatz(lngC))) Then
            If lngC = UBound(vntQuelle) Then lngSpalte = lngSpalte + 4
         End If
      Next lngC
   '   strDatei = Dir()
   'Loop
 Next iCnt
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

[schauan]

Hallöchen,

was heißt denn "... passiert nichts …" ?

Werden wenigstens erst mal die Dateien in Spalte H eingetragen?

[Philipp1344]

Guten Morgen,

ja die Dateipfade sind in Spalte H (was aber davon abhängt ob ich zuletzt eine Zelle in Spalte H markiert hatte oder nicht).
Nur wenn ich dann meinen 2. Button klicke (Dateien einpflegen) dann passiert schlichtweg nichts

Grüße
Philipp

[schauan]

Hallo Philipp,


bei mir sieht das Ergebnis so aus, geht in Spalte C übrigens bis C60. #BEZUG steht da, weil ich das Blatt Tabelle1 in der gewählten Datei nicht habe Vorher kam übrigens noch eine Meldung, wo ich ein Blatt wählen sollte. … Stehen denn in Deinen Tabellen auch Daten drin?

Arbeitsblatt mit dem Namen 'Links'
	C	D	E
1
2			#BEZUG!
3	#BEZUG!

Verwendete Systemkomponenten: [Windows (32-bit) NT 10.00] MS Excel 2016

Diese Tabelle wurde mit Tab2Html (v2.6.0) erstellt. ©Gerd alias Bamberg

[Philipp1344]

Hi schauan, da meine Datei leider nach wie vor zu groß zum anhängen ist folgender Versuch:

Meine Datei im Anhang, die zwei Makros hier:

Button: einpflegen

Code:

Sub prcX()
 Dim strDatei As String
 Dim lngSpalte As Long
 Dim lngC As Long
 Dim vntQuelle As Variant
 Dim vntZiel As Variant
 Dim vntVersatz As Variant
 Dim iCnt%, iCut%, strPfad$
 For iCnt = 1 To 100 'mal auf maximal 100 Dateien beschraenkt
   If Cells(iCnt, 8).Value = "" Then Exit For
   'im Unterverzeichnis Dateien bitte anpassen
   strDatei = Cells(iCnt, 8).Value
   iCut = InStrRev(strDatei, "\")
   strPfad = Left(strDatei, iCut)  'Falls der Pfad gebraucht wird
   strDatei = Mid(strDatei, iCut + 1)
   'On Error Resume Next
   'Eintrag in Spalte E
   vntQuelle = Array("E19:E74", "G8", "G9", "G10")
   vntZiel = Array(5, 3, 2, 1)
   vntVersatz = Array(-1, -1, 1, -1)
   lngSpalte = 4
   'im Unterverzeichnis Dateien bitte anpassen
   'strDatei = Dir(ThisWorkbook.Path & "\PBDs\*.xls*")
   'Do While strDatei <> ""
      For lngC = 0 To UBound(vntQuelle)
         If GetDataClosedWB(strPfad, _
            strDatei, "Tabelle1", CStr(vntQuelle(lngC)), _
            ThisWorkbook.Worksheets(1).Cells(vntZiel(lngC), lngSpalte).Offset(, vntVersatz(lngC))) Then
            If lngC = UBound(vntQuelle) Then lngSpalte = lngSpalte + 4
         End If
      Next lngC
   '   strDatei = Dir()
   'Loop
 Next iCnt
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

Button: Dateiauswahl

Code:

Option Explicit

Const vbDropEffectNone = 0
Const vbDropEffectCopy = 1
Const vbDropEffectMove = 2

Const vbCFFiles = 15
Private Sub bAbbrechen_Click()
  Unload Me
End Sub
Private Sub ListView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Long
  If Data.GetFormat(vbCFFiles) Then
     s = ActiveCell.Column
     z = Cells(ActiveSheet.Rows.Count, s).End(xlUp).Row
     If Not (IsEmpty(Cells(z, s))) Then z = z + 1
     For i = 1 To Data.Files.Count
         ActiveSheet.Cells(z, s).Hyperlinks.Add ActiveSheet.Cells(z, s), Data.Files(i)
         z = z + 1
     Next
  End If
End Sub
Private Sub ListView1_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
   Effect = vbDropEffectCopy
End Sub

Private Sub UserForm_Click()

End Sub

Schau mal ob du damit arbeiten kannst...ansonsten muss ich mir was anderes einfallen lassen.

PS: Ja in meinen Dateien waren Werte drin.

[Steffl]

Hallo Philipp,

setze dir mal in dieser

Code:

For iCnt = 1 To 100

Codezeile einen Haltepunkt. Gehe hierzu mit dem Cursor in die Codezeile und drücke die F9-Taste. Starte das Makro wie gewohnt. Jetzt hält Excel an dieser Position an und Du kannst mit der F8-Taste sehen, wie der Code abgearbeitet wird. Weitere Informationen gibt es hier.

[schauan]

Hallöchen,

das ist nicht so ganz stimmig mit meinem Vorschlag. Ich bin davon ausgegangen, dass die Einträge immer in die gleiche Spalte kommen und es in Zeile 1 los geht. Muss beides nicht sein, siehe Code beim Dateien eintragen:

s = ActiveCell.Column
z = Cells(ActiveSheet.Rows.Count, s).End(xlUp).Row

Wenn die Spalte beim Import der Daten die gleiche ist wie beim Dateien eintragen müsste man es analog tun und dann auch die Startzeile entsprechend festlegen, z.B..

For iCnt = 61 To 100 'mal auf maximal Zeile 100 beschraenkt
If Cells(iCnt, ActiveCell.Column).Value = "" Then Exit For
'im Unterverzeichnis Dateien bitte anpassen
strDatei = Cells(iCnt, ActiveCell.Column).Value

Ob nun eine feste Zeilenzahl für den Anfang der Schleife gut ist sei mal dahingestellt. Flexibel könnte man es nur halten, wenn man sich den z-Wert merkt. Allerdings ist der ja auch nicht unbedingt korrekt, wenn man die Dateinamen z.B. einzeln rein holt.