Daten zusammenfügen

Sub Import_mit_Dialog() Dim Quelle As Object, Ziel As Object Dim Datei As String Dim r As Range Dim anz As Long Dim c_ges As Long Dim col As New Collection On Error GoTo Fehler 'Dialog "Datei öffnen" anzeigen Datei = Application.GetOpenFilename("Excel-Dateien(*.xls),*xls") 'Abbrechen falls keine Datei ausgewählt If Datei = "Falsch" Then MsgBox "keine Datei ausgewählt", , "Abbruch" Exit Sub End If 'MsgBox "Ausgewählte Datei: " & Datei, , "" 'Ausgewählte Datei öffnen Workbooks.Open Filename:=Datei Set Quelle = ActiveWorkbook.Worksheets(1) ' bedeutet das erste Blatt der Datei Set Ziel = ThisWorkbook.Worksheets("temp") 'kopieren und einfügen Quelle.UsedRange.Copy Ziel.Cells(1, 1) 'Sheets("temp").Select ActiveWorkbook.Close 'Speicher freigeben Set Quelle = Nothing Set Ziel = Nothing Exit Sub Fehler: Set Quelle = Nothing Set Ziel = Nothing MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _ & "Beschreibung: " & Err.Description _ , vbCritical, "Fehler" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Import_mit_Dialog() Dim wkbQuelle As Workbook, Quelle As Worksheet Dim Ziel As Object, Spalte_Z As Long Dim Datei As Variant On Error GoTo Fehler 'Dialog "Datei öffnen" anzeigen Datei = Application.GetOpenFilename("Excel-Dateien(*.xls),*xls") 'Abbrechen falls keine Datei ausgewählt If Datei = False Then MsgBox "keine Datei ausgewählt", , "Abbruch" Exit Sub End If 'MsgBox "Ausgewählte Datei: " & Datei, , "" 'Zieltabelle setzen Set Ziel = ThisWorkbook.Worksheets("temp") Spalte_Z = 1 '1. Einfügespalte 'Ausgewählte Datei öffnen Set wkbQuelle = Workbooks.Open(Filename:=Datei, ReadOnly:=True) For Each Quelle In ActiveWorkbook.Worksheets 'kopieren und einfügen Quelle.UsedRange.Copy Ziel.Cells(1, Spalte_Z) Spalte_Z = Spalte_Z + Quelle.UsedRange.Columns.Count Next wkbQuelle.Close savechanges:=False 'Speicher freigeben Set Quelle = Nothing Set Ziel = Nothing Exit Sub Fehler: Set Quelle = Nothing Set Ziel = Nothing MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _ & "Beschreibung: " & Err.Description _ , vbCritical, "Fehler" End Sub

Hallo Franz,
es ist mir ein wenig peinlich den ich wollte dieses Problem stück für stück lösen aber dies sollte ich mir vielleicht mal abgewöhnen. das Projekt ist ein wenig grösser. Ich habe Dateien aus einem anderem Programm die sehen so aus wie die Beispiel- Datei. diese Datei bereite ich mit dem untenstehenden macro Leerzeilen entfernen ( Call Leerzeilenlöschen PS diesen Trick habe ich von Dir abgeschaut), auf so das ich nur noch eine Zeile je Name habe. ( in den Zeilen wo noch eine verbundene Zeile mit dran hängt benötige ich nur den oberen Teil). Nach dem aufbereiten kopiere ich die Tabelle temp in meine richte Vorlage rein. Eine weitere Tabelle enthält Verknüpfungen zu dieser Datei dies sind dann Formeln die bestimmte Sachen wie z.B. Frei von bis finden. Weiter geht es dann mit einem Seriendruckmacro um Formulare zu drucken.
Da dieses dumme Export Programm jeden Monat einzeln ablegt muss ich irgendwie diese Daten zusammen bringen. Hier ist eigentlich wichtig das die Nr. Spalte z.b 11 aus Zeile 4 auch mit der Nr. 11 aus den anderen Blättern eine Zeile bilden. Aber ich habe so ca. 100 Test gefahren diese sind immer die selben Zeilennummer. So das ich eigentlich Nur noch die Spalten a und b aus den andern Blättern loswerden muss. OH OH Du hast recht wenn ein neuer Name im zweiten Monat dazukommt habe ich Datensalat. Was mache ich nun? Mit pivat? Das Endprodukt ist ein Formular als Seriendruck ( was auch alles schon funktioniert). Nur das Monatsübergreifende nicht. Kann man das zeilenproblem mit VBA lösen?Fals nicht Kannst Du mir trotzdem die zwei Spalten wegmachen? solange kein neuer Name mitten im Quartal dazukommt ist ja alles ok.
Besten dank schon mal für deine viele Mühe.
Liebe Grüsse Thomas
PS: was Hajo meinte weis ich nicht so richtig

Sub Leerzeilenlöschen()
'   Leerzeilen löschen einschließlich der Zeilen die entstehen wenn Zeilen am ende
'   gelöscht werden, auch Leerzeilen in der Tabelle werden gelöscht
'   von Wolf.W.Radzinski
'   es wurden nicht alle Leerzeilen in einer Datei erkannt
'   darum Ergänzung
On Error Resume Next
Dim r As Range
Dim anz As Long
Dim c_ges As Long
Dim col As New Collection
c_ges = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
For Each r In ActiveSheet.UsedRange.EntireRow
anz = 0
'       ******** Hajo.Ziplies@web.de
Dim i As Byte
Dim L As Byte
L = 0
For i = 1 To 2   ' hier wird geprüft ob spalte 1 bis zwei leer sind
If Cells(r.Row, i) <> "" Then
L = 1
Exit For
End If
Next i
If L = 0 Then col.Add r
'        anz = r.SpecialCells(xlCellTypeBlanks).Count
'        If anz >= c_ges Then col.Add r
Next
For Each r In col
r.Delete
Next
End Sub

Hallo Thomas,
es ist mir ein wenig peinlich den ich wollte dieses Problem stück für stück lösen
Dies ist ja auch der richtige Ansatz - ein größes Projekt in Teilprojekte zerlegen. Man muss halt nur aufpassen, dass man die Teilprojekte richtig anlegt und hier bei Fragen am passenden Stand der Dateien ansetzt.
Nachfolgend zwei Text-Dateien mit Makros. Ich hab dabei das Löschen der Leerzeilen integriert.
In dieser Textdatei ist das Makro angepasst, so dass ab dem 2. Blatt der Block ab Spalte C kopiert wird - mit dem Risiko, dass neue/nicht mehr vorhanden Nr. in einem Folgemonat Probleme machen.
https://www.herber.de/bbs/user/97469.txt
In dieser Textdatei hab ich das Makro erweitert, so dass beim 1. Monat der komplette Datenbereich inkl. Spalten A:B kopiert wird. Bei den Folgeblättern wird die Quelle zeilenweise abgearbeitet und dabei die Nr. im Blatt "temp" gesucht und die Daten in die jeweils gefundene Zeile kopiert. Ist die Nr. noch nicht vorhanden werden Nr. und Personal + Daten ans Ende der Liste kopiert.
https://www.herber.de/bbs/user/97470.txt
Gruß
Franz

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread