Hallo zusammen,
ich versuche mal grob mein Problem zu beschreiben. Es gibt mehrere Excel-Dateien (Excel Version 2010). Dies sind Meldebögen
für Kunden. Der Aufbau entspricht nicht einem klassischen Tabellenaufbau. In einzelnen Zellen (B1, B3, B5, B6, E3)stehen Daten wie Name,
Kundennummer etc.. Darunter folgt ein normaler Tabellenaufbau von A10:A19 bis I10:I19. Durch Klick auf einen Button
sollen die Daten der einzelnen Dateien importiert und in der Hauptdatei von A3:Q3 eingefügt werden. Wenn mehrere Dateien ausgewählt sind,
werden die Daten automatisch eine Zeile weiter nach unten eingetragen. Das funktioniert so weit auch wie ich mir das vorstelle.
Mein Problem: In den Zellen B1, B3, B5, B6, E3 stehen immer nur Einzelwerte. Von A10:A19 bis I10:I19 können mehrere Werte auftreten.
Bsp.: Kunde Max Mustermann (B1) hat 3 Produkte x (A10:A13). Werden Die Daten nun Importiert so habe ich in der Hauptsatei das Problem, dass bei mehreren Dateien
die Zeilen versetzt werden. Also der Neue Kunde steht zwar unter Max Mustermann, aber direkt neben den Produkten von Max Mustermann.
Wie kann ich das Problem lösen, dass wenn z.B die Range A10:A13 umfasst die einzelne Zelle B1 automatisch um die jeweilige größe der Spalte nach unten versetzt wird?
Am liebsten wäre mir, wenn dann z.B 3 mal der Name Max Mustermann erscheinen würde. Ich hoffe Ihr könnt mir bei meinem Problem helfen :)
Hier mein Code:
Public Sub Daten_mehrerer_Dateien_zusammenfuehren()
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim lngAnzahl As Long
Set WBZ = ActiveWorkbook
WBZ.Worksheets(1).Range("A3:IV65536").ClearContents
varDateien = _
Application.GetOpenFilename("Datei(*.xlsm),*.xlsm", False, "Bitte gewünschte Datei(en) markieren", False, True)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
For lngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(lngAnzahl))
WBQ.Worksheets(1).Range("A10:A19").Copy
WBZ.Worksheets(1).Range("E" & WBZ.Worksheets(1).Range("E65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("B10:B19").Copy
WBZ.Worksheets(1).Range("C" & WBZ.Worksheets(1).Range("C65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("E10:E19").Copy
WBZ.Worksheets(1).Range("M" & WBZ.Worksheets(1).Range("M65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("F10:F19").Copy
WBZ.Worksheets(1).Range("H" & WBZ.Worksheets(1).Range("H65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("G10:G19").Copy
WBZ.Worksheets(1).Range("Q" & WBZ.Worksheets(1).Range("Q65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("H10:H19").Copy
WBZ.Worksheets(1).Range("I" & WBZ.Worksheets(1).Range("I65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("I10:I19").Copy
WBZ.Worksheets(1).Range("N" & WBZ.Worksheets(1).Range("N65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("B1").Copy
WBZ.Worksheets(1).Range("A" & WBZ.Worksheets(1).Range("A65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("B3").Copy
WBZ.Worksheets(1).Range("D" & WBZ.Worksheets(1).Range("D65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("E3").Copy
WBZ.Worksheets(1).Range("B" & WBZ.Worksheets(1).Range("B65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("B5").Copy
WBZ.Worksheets(1).Range("K" & WBZ.Worksheets(1).Range("K65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Worksheets(1).Range("B6").Copy
WBZ.Worksheets(1).Range("L" & WBZ.Worksheets(1).Range("L65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, operation:=xlNone, skipblanks:=False, Transpose:=False
WBQ.Close
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Es wurden " & UBound(varDateien) & " Dateien zusammengefügt.", 64
Exit Sub
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
If Err.Number = 13 Then
MsgBox "Es wurde keine Datei ausgewählt"
Else
MsgBox "Es ist ein Fehler aufgetreten!" & vbCr _
& "Fehlernummer: " & Err.Number & vbCr _
& "Fehlerbeschreibung: " & Err.Description
End If
End Sub