VBA Code > Daten aus vielen EXEL-Dateien in einer Datei vereinen

[Brinkhoff]

Hallo Zusammen.

Ich benötige Hilfe bei der Anpassung eines VBA Codes welchen ich von jemandem für ein anderes Projekt bekommen habe.
Leider kann ich den Ersteller nicht mehr erreichen um ihn zu fragen.
Daher mein Versuch hier Hilfe zu bekommen.

Zuerst der Code:

Code:

Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("C:\XXX\")
Set fc = f.Files

Dim a, b

a = 1

For Each f1 In fc
   
 Workbooks.Open "C:\XXX\" & f1.Name

 Dim Ziel, Quelle As Worksheet

 Set Ziel = Workbooks.Item(1).Worksheets(1)
 Set Quelle = Workbooks.Item(2).Worksheets(1)

 b = 0
 
 While Quelle.Cells(b + 9, 1) <> ""
   
   Ziel.Cells(a, 1) = Quelle.Cells(3, 2)
   Ziel.Cells(a, 2) = Quelle.Cells(b + 9, 1)
   Ziel.Cells(a, 3) = Quelle.Cells(b + 9, 3)
   Ziel.Cells(a, 4) = Quelle.Cells(b + 9, 5)
   b = b + 1
   a = a + 1
   
 Wend

 Set Ziel = Nothing
 Set Quelle = Nothing

 Workbooks.Item(2).Close (False)

Next
End Sub

Der sollte mir aus vielen kleinen Exeldateien eine große Liste in einer neuen Datei machen.
Das möchte ich nun wieder mit einem anderen Projekt machen.
Allerdings verstehe ich die Codierung bezüglich der Quell- und Zielzellen nicht.
Sie scheinen von einer Zelle aus zu gehen und sich auf diese zu beziehen.
Ich wollte nun einfach den Part auf meine neuen Dateien anpassen und dabei einfach absolute Zellangaben machen:

Code:

   Ziel.Cells(a, 2) = Quelle.Cells(b, 3)
   Ziel.Cells(c, 2) = Quelle.Cells(b, 4)
   Ziel.Cells(d, 2) = Quelle.Cells(b, 5)
   Ziel.Cells(e, 2) = Quelle.Cells(b, 6)
   Ziel.Cells(f, 2) = Quelle.Cells(b, 7)
   Ziel.Cells(g, 2) = Quelle.Cells(b, 8)
   Ziel.Cells(h, 2) = Quelle.Cells(b, 9)
   Ziel.Cells(i, 2) = Quelle.Cells(b, 10)
   Ziel.Cells(j, 2) = Quelle.Cells(b, 11)
   Ziel.Cells(k, 2) = Quelle.Cells(b, 12)
   Ziel.Cells(l, 2) = Quelle.Cells(b, 13)
   Ziel.Cells(m, 2) = Quelle.Cells(b, 14)
   Ziel.Cells(n, 2) = Quelle.Cells(b, 15)
   Ziel.Cells(o, 2) = Quelle.Cells(b, 16)
   Ziel.Cells(p, 2) = Quelle.Cells(b, 17)
   b = b + 1
   a = a + 1

Das will aber so nicht funktionieren.
Kann mir jemand einen Tip geben wie ich den Code schreiben muss um die oben genannten Quellen in die jeweiligen Ziele schreiben lassen kann?
Danke im Voraus für eure Mühen.

[Fennek]

Hallo,

in dem Bereich der Zieldatei, kann die Formel nur funktionieren, wenn vorher die Variablen c bis p definiert sind. Bei der "Quelle" ist es immer die Zeile b, die am Ende des Blocks hochgezählt wird.

Ohne jede Detailkenntnis: können nicht anstelle der vielen einzelnen Zellen ganze Ranges kopiert werden.


Mfg

[Brinkhoff]

Hallo,

in dem Bereich der Zieldatei, kann die Formel nur funktionieren, wenn vorher die Variablen c bis p definiert sind. Bei der "Quelle" ist es immer die Zeile b, die am Ende des Blocks hochgezählt wird.

Ohne jede Detailkenntnis: können nicht anstelle der vielen einzelnen Zellen ganze Ranges kopiert werden.


Mfg

Hallo Fennek,

im Prinzip kann immer der Block: (Zelle B3 bis B17) in den Zielbereich (Spalte A bis P) kopiert werden.
Nur wie schreibe ich das? Ich finde leider die Logik im Originalcode nicht um ihn umschreiben zu können.

[Fennek]

Hallo,

z.Zt. sitze ich nicht vor dem Rechner, deswegen ungeprüft und aus dem Gedächtnis.

Quelle: range("b3:b17").copy
Ziel: range("a").pastespecial 'hier das Schlüsselwort für transponieren eingeben


Mfg

[atilla]

Hallo,

theoretisch so:

Code:

Sub kopieren()
 Dim fs, f, f1, fc, s
 Dim Ziel As Worksheet, Quelle As Worksheet
 Set fs = CreateObject("Scripting.FileSystemObject")
 Set f = fs.GetFolder("C:\Users\Username\Desktop\") 'Pfad anpassen
 Set fc = f.Files
 
 Dim a As Long
 a = 2
 Application.ScreenUpdating = False
 For Each f1 In fc
   Workbooks.Open "C:\Users\Username\Desktop\" & f1.Name 'Pfad anpassen
   Set Ziel = Workbooks.Item(1).Worksheets(1)
   Set Quelle = Workbooks.Item(2).Worksheets(1)
   Quelle.Range("B3:B17").Copy
   Ziel.Cells(a, 1).PasteSpecial Paste:=xlValues, Transpose:=True
   a = a + 1
   Set Ziel = Nothing
   Set Quelle = Nothing
   Workbooks.Item(2).Close (False)
 Next
 Application.ScreenUpdating = True
End Sub

[Brinkhoff]

Nee, den will er so noch nicht ganz:

Code:

Sub Import()
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("X:\Stücklisten\Erneuerung-Stücklisten\In Arbeit\Artikelstamm_Neu\Dokumentation\TEST")
Set fc = f.Files

Dim a, b

a = 1

For Each f1 In fc
   
 Workbooks.Open "X:\Stücklisten\Erneuerung-Stücklisten\In Arbeit\Artikelstamm_Neu\Dokumentation\TEST\" & f1.Name

 Dim Ziel, Quelle As Worksheet

 Set Ziel = Workbooks.Item(1).Worksheets(1)
 Set Quelle = Workbooks.Item(2).Worksheets(1)

 b = 0
 
 While Quelle.Cells(b + 3, 1) <> ""
   
Quelle: Range("b3:b17").Copy
Ziel: Range("a").PasteSpecial , Transpose

    b = b + 1
   a = a + 1
   
 Wend

 Set Ziel = Nothing
 Set Quelle = Nothing

 Workbooks.Item(2).Close (False)

Next
End Sub

[Brinkhoff]

Nee, den will er so noch nicht ganz:

Code:

Sub Import()
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("X:\Stücklisten\Erneuerung-Stücklisten\In Arbeit\Artikelstamm_Neu\Dokumentation\TEST")
Set fc = f.Files

Dim a, b

a = 1

For Each f1 In fc
   
 Workbooks.Open "X:\Stücklisten\Erneuerung-Stücklisten\In Arbeit\Artikelstamm_Neu\Dokumentation\TEST\" & f1.Name

 Dim Ziel, Quelle As Worksheet

 Set Ziel = Workbooks.Item(1).Worksheets(1)
 Set Quelle = Workbooks.Item(2).Worksheets(1)

 b = 0
 
 While Quelle.Cells(b + 3, 1) <> ""
   
Quelle: Range("b3:b17").Copy
Ziel: Range("a").PasteSpecial , Transpose

    b = b + 1
   a = a + 1
   
 Wend

 Set Ziel = Nothing
 Set Quelle = Nothing

 Workbooks.Item(2).Close (False)

Next
End Sub

Die Methode 'range' für das Objekt '_Global' ist fehlgeschlagen.
Und dann verweist er auf "Ziel: Range("a").PasteSpecial , Transpose"

[atilla]

Hallo,

musst halt ein wenig zureden, dann will er schon.

Du musst statt Deines bisherigen Codes meinen einsetzen.

[Fennek]

Hallo,

nach Augenscheinprüfung halte ich Atilla's Code'für perfekt, aber es wird vorausgesetzt,'dass ausschlieslich xl-Dateien in dem Ordner sind. Falls nicht, wäre eine ergänzende Prüfung auf den Datei-Typ notwendig.

Mfg

[Brinkhoff]

Hallo,

musst halt ein wenig zureden, dann will er schon.

Du musst statt Deines bisherigen Codes meinen einsetzen.

Oh atilla, du bist ja auch dabei.
Deine Antwort habe ich erstmal glatt überlesen.
Meine letzte Antwort war nur auf die von Fennek bezogen.

Also mit deiner klappt was!!!
Ich bekomme zwar erst einen Fehler das die Mappe1.xlsm bereits geöffnet ist.
Und wenn ich sie dann aber nicht erneut öffnen lasse "NEIN" dann meckert er noch "Laufzeitfehler 1004" Methode 'open' für das Objekt 'Workbooks' ist fehlgeschlagen.

Aber jetzt kommts: debugge ich das ganze und gehe aus dem VBA Editor zurück in die Arbeitsmappe sind die Daten da.