Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Untereinander, statt nebeneinander kopieren

Untereinander, statt nebeneinander kopieren
19.10.2017 14:36:22
Horst
Hallo zusammen,
vor einigen Tagen hat mir ein User freundlicherweise ein Makro für mich gebastelt,
das Inhalte vieler Dateien in einer einzigen zusammenfasst.
https://www.herber.de/bbs/user/116611.xlsm
Da ich berufsbedingt teilweise nur selten in dieses Forum gucken kann und mein Anliegen schlecht vormuliert habe, wurde der Thread leider geschlossen, bevor das Makro 100% richtig läuft. Es ist sooo kurz davor, allerdings bekomm ich es selber nicht hin..
Kurz zum Makro:
Es durchsucht alle .csv Docs in meinem Beispielordner nach einem Suchwort,
kopiert dann die 1. Spalte und danach alle Spalten in denen das Suchwort gefunden wurde daneben. Anschließend wird das nächste Dokument durchsucht und die Spalten in denen das Suchwort gefunden wurde ebenfalls neben der zuletzt benutzten Spalte eingefügt, sodass die Spaltenanzahl immer größer wird, die Zeilenanzahl immer gleich bleibt.
Damit das Makro Sinn ergibt müssten die Daten nach der 1. Datei allerdings unter die vorher erstellte Tabelle kopiert werden, sodass die Spaltenanzahl immer gleich bleibt, während die Zeilen immer mehr werden.
Ich bin mir ziemlich sicher dass in dem Bereich

Set r = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
Set f = r.Find(what:=bId, LookIn:=xlValues, lookat:=xlPart)
If Not f Is Nothing Then
.Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row - 1).Copy _
WsZ.Cells(1, 1)
ff = f.Address
Do
.Range(.Cells(1, f.Column), _
.Cells(.Rows.Count, f.Column).End(xlUp).Offset(-1, 0)).Copy _
WsZ.Cells(1, WsZ.Columns.Count).End(xlToLeft).Offset(, 1)
Set f = r.FindNext(f)

lediglich f.column gegen f.row oder xltoleft gegen xldown (So etwas in der Art)
getauscht werden müsste, aber ich bin nach ewigem rumprobieren kläglich gescheitert..
Über eure Hilfe wäre ich wirklich dankbar!
Viele Grüße
Horst

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Untereinander, statt nebeneinander kopieren
19.10.2017 15:08:24
yummi
Hallo Horst,
evtl so etwas in der Art, ist nicht getestet

if Not f Is Nothing Then
.Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row - 1).Copy
WsZ.Cells(WsZ.cells(WsZ.Rows.count,1).end(xlup).row+1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= False, Transpose:=True
Gruß
yummi
AW: Untereinander, statt nebeneinander kopieren
19.10.2017 16:13:30
Horst
Hallo yummi,
danke für deine Antwort.
Wahrscheinlich ist es schwierig das Makro ohne Beispieldatei nachzuvollziehen,
aber findet das "einfügen" nicht erst nach dem "do" statt?
Setze ich deinen Code zwischen ..xlpart) und ..ff = f.Address ein,
kopiert es die Tabellen trotzdem nebeneinander (Und zerschießt die Daten ein wenig :D)
Viele Grüße
Horst
Anzeige
AW: Untereinander, statt nebeneinander kopieren
19.10.2017 16:49:53
yummi
Hallo Horst,
mach mal eine Beispieldatei fertig, die einzulesenden Daten kannst du auf ein extra sheet legen (für eine Datei auszugweise)
Und zeig mal wie es aussehen soll.
Da du auch nur einen kleinen Ausschnitt deines Codes gepostet hast, ist das schwierig nachzuvollziehen
Gruß
yummi
AW: Untereinander, statt nebeneinander kopieren
19.10.2017 23:30:46
Horst
Hey yummi,
im fertigen Makro liegt bereits auf dem 3. Tabellenblatt eine Beispieltabelle,
das hätte ich natürlich dazu sagen können :D
Dubliziert man diese Tabelle (Hat 2 Dateien im Beispielordner), ändert den Zeitstempel der 2. Datei um einen Tag (mir ist bewusst dass er im Beispiel nicht vollständig ist) und legt sie jeweils aufs erste Tabellenblatt der neuen .csv würde man für den Fall, dass das Suchwort "G3" ist, folgendes erhalten:

Spalte A besitzt 40 statt 20 Zeilen. Zeit von 12.07.2016 00:00:00 bis 14.07.16 00:00:00.
In Zeile 1 wird in jeder Datei 7x das gesuchte Wort "G3" gefunden,
dementsprechend werden Spalten B-H gefüllt, ebenfalls insgesamt 40 Zeilen.
Da außer in Spalte A leere Zellen existieren können,
sollte die "Form" jeder Urspungsdatei erhalten bleiben.
Ich hoffe das war einigermaßen verständlich :)
Ansonsten erstelle ich morgen mal Datei 1, Datei 2 und eine Ergebnistabelle.
Viele Grüße
Anzeige
AW: Untereinander, statt nebeneinander kopieren
20.10.2017 09:42:20
yummi
Hallo Horst,
sry hatte deine Beispieldatei übersehen ;-)
Du kopierst nach deinem Algorithmus alles ausser der letzen Zeile, das habe ich mal so gelassen

Sub GebaeudeDatenImportieren()
Dim WbZ As Workbook: Set WbZ = ThisWorkbook
Dim WsZ As Worksheet, WsI As Worksheet, Wbq As Workbook
Dim Datei$, Pfad$, bId$, r As Range, f As Range, ff$
'---- Hier anpassen ----
'Name des Blattes in dem die Gebäude-ID definiert wird (hier Tabelle1)
Set WsI = WbZ.Worksheets("Tabelle1")
' Name des Zielblattes (in das die Daten importiert werden)
Set WsZ = WbZ.Worksheets("Tabelle2")
' Pfad zu den Quell-Dateien (.csv-Dateien)
Pfad = "C:\Temp"
'---- Anpassen ENDE ----
Application.ScreenUpdating = False
bId = WsI.Range("B1").Text
Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\")
Datei = Dir(Pfad & "*.csv", vbDirectory)
Do Until Datei = ""
Set Wbq = Workbooks.Open(Pfad & Datei, local:=True)
With Wbq
Wbq.Activate
With .Worksheets(1)
Set r = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
Set f = r.Find(what:=bId, LookIn:=xlValues, lookat:=xlPart)
If Not f Is Nothing Then
.Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row - 1).Copy
WsZ.Cells(WsZ.Cells(WsZ.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial  _
Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
ff = f.Address
Do
.Range(.Cells(1, f.Column), .Cells(.Rows.Count, f.Column).End(xlUp). _
Offset(-1, 0)).Copy
WsZ.Cells(WsZ.Cells(WsZ.Rows.Count, 1).End(xlUp).Row + 1, 1). _
PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Set f = r.FindNext(f)
Loop While Not f Is Nothing And f.Address  ff
End If
End With
Set f = Nothing
.Close False
End With
Datei = Dir
Loop
MsgBox "-Daten aus [" & Pfad & "] importiert!", vbInformation
Set WbZ = Nothing: Set WsZ = Nothing: Set WsI = Nothing
Set Wbq = Nothing: Set r = Nothing
End Sub
Sonst musst du in den beiden copy Zeilen die -1 entfernen.
Gruß
yummi
Anzeige
AW: Untereinander, statt nebeneinander kopieren
20.10.2017 17:44:57
Horst
Hallo yummi,
das klappt ebenfalls nur fast perfekt :D
So sieht es im Moment aus: https://i.imgur.com/1JR6LOv.png
Und so sollte es hinterher aussehen: https://i.imgur.com/7crD0vF.png
Das mit dem beschreiben ohne Bilder sollte ich wohl noch üben.
Danke für deine Mühen :)
Gruß
AW: Untereinander, statt nebeneinander kopieren
23.10.2017 09:49:06
yummi
Hallo Horst,
kannst Du mir bitte mal eine Datei mit eingangsdaten schicken, irgendwie habe ich gerade den Faden verloren. :-)
Nur damit wir von der selben Ausgangslage ausgehen.
Gruß
yummi
AW: Untereinander, statt nebeneinander kopieren
23.10.2017 10:23:20
Horst
Hallo yummi,
hier ist mal eine Beispieldatei :)
https://www.herber.de/bbs/user/117164.xlsx
Tabelle 1: Tag 1
Tabelle 2: Tag 2
Tabelle 3: Falls nur Tag 1 und 2 im Ordner liegen, Endergebnis für Suchwort "G1"
Ich hoffe das Beispiel hilft um Klarheit zu schaffen
Viele Grüße
Horst
Anzeige
AW: Untereinander, statt nebeneinander kopieren
23.10.2017 10:59:52
yummi
Hallo Horst,
das ist aber eine Datei wie es aussehen soll, nicht wie Daten aussehen, die eingelesen werden oder?
Gruß
yummi
AW: Untereinander, statt nebeneinander kopieren
23.10.2017 11:52:02
Horst
Hey yummi,
Tabelle 1 für sich alleine wäre eine Datei, die eingelesen wird. Tabelle 2 ebenso.
Tabelle 3 stellt dann das Endergebnis dar.
Gruß
Horst
AW: Untereinander, statt nebeneinander kopieren
23.10.2017 12:07:17
yummi
Hallo Horst,
aber die sind doch nur 1:1 übernommen und unter einander kopiert?
Ich dachte du wolltest transponieren. Das versteh ich jetzt nicht
Gruß
yummi
AW: Untereinander, statt nebeneinander kopieren
23.10.2017 13:13:18
Horst
Ach jetzt versteh ich deine Verwirrung!
Der Titel von diesem Thread war bereits auf das Makro bezogen, das mir bei meiner ersten Nachfrage erstellt wurde. Dabei wurden die einzelnen Tabellen importiert und alle nebeneinander kopiert.
Da die Form der Daten an sich nicht geändert werden soll war das Makro bereits fast perfekt, bis auf die Tatsache, dass untereinander kopiert werden soll.
Du hast mit deiner Lösung also schon mehr gemacht als nötig, es soll tatsächlich nur ganz stumpf übernommen werden :D Hoffentlich ist dir das jetzt nicht zu einfach, transponieren ist nicht nötig.
Viele Grüße und soooorry!
Anzeige
AW: Untereinander, statt nebeneinander kopieren
23.10.2017 16:00:30
yummi
Hallo Horst,
die activate und die select zeilen, waren nur zum Test drin, die kannst du löschen.
also so:

Sub GebaeudeDatenImportieren()
Dim WbZ As Workbook: Set WbZ = ThisWorkbook
Dim WsZ As Worksheet, WsI As Worksheet, Wbq As Workbook
Dim Datei$, Pfad$, bId$, r As Range, f As Range, ff$
Dim lastZ As Long
Dim lastS As Integer
Dim lastZDest As Long
Dim i As Integer
Dim s As Integer
'---- Hier anpassen ----
'Name des Blattes in dem die Gebäude-ID definiert wird (hier Tabelle1)
Set WsI = WbZ.Worksheets("Tabelle1")
' Name des Zielblattes (in das die Daten importiert werden)
Set WsZ = WbZ.Worksheets("Tabelle2")
' Pfad zu den Quell-Dateien (.csv-Dateien)
Pfad = "C:\Temp\"
'---- Anpassen ENDE ----
Application.ScreenUpdating = False
bId = WsI.Range("B1").Value
Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\")
Datei = Dir(Pfad & "*.csv", vbDirectory)
Do Until Datei = ""
Set Wbq = Workbooks.Open(Pfad & Datei, local:=True)
lastZ = BestimmeLetzteZeile(Wbq.Worksheets(1), 1)
lastS = BestimmeLetzteSpalte(Wbq.Worksheets(1), 1)
s = 1
lastZDest = BestimmeLetzteZeile(WsZ, 1)
If lastZDest > 1 Then
lastZDest = lastZDest + 1    'hinter letzte Zeile setzen
End If
With Wbq
With .Worksheets(1)
For i = 1 To 1
.Range(.Cells(1, i), .Cells(lastZ, i)).Copy WsZ.Cells(lastZDest, s)
s = s + 1
Next i
For i = 2 To lastS
If .Cells(1, i).Value = bId Then
.Range(.Cells(1, i), .Cells(lastZ, i)).Copy WsZ.Cells(lastZDest, s)
s = s + 1
End If
Next i
End With
.Close False
End With
Datei = Dir
Loop
MsgBox "-Daten aus [" & Pfad & "] importiert!", vbInformation
Set WbZ = Nothing: Set WsZ = Nothing: Set WsI = Nothing
Set Wbq = Nothing: Set r = Nothing
End Sub
sonst flackert es so ;-)
Gruß
yummi
Anzeige
AW: Untereinander, statt nebeneinander kopieren
24.10.2017 12:31:08
Horst
Hey yummi,
die ersten Tests liefen perfekt, Wahnsinn!
Vielen vielen Dank, falls noch was ist meld ich mich wieder,
aber bis jetzt sieht es so aus als hättest du es perfekt gelöst! :)
Viele Grüße

308 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige