Guten Morgen,
konnte gestern nicht mehr fertig stellen. Hier ist jetzt der Code. Diesen unter der Schaltfläche einfuegen. Denke, du weisst wie.
Dim vntPathAndFileNames As Variant 'kein String !
Dim strPathAndFile As String
Dim lngI As Long, LZM As Long, LZZ As Long
Dim wbkMappe As Workbook
Dim wks As Worksheet
Dim wbkZiel As Workbook
Application.ScreenUpdating = False
Set wbkZiel = ThisWorkbook
vntPathAndFileNames = Application.GetOpenFilename(FileFilter:="Excel Dateien (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Zu öffnende Datei auswählen", MultiSelect:=False)
If VarType(vntPathAndFileNames) = vbBoolean Then
MsgBox "Abgebrochen!"
Else
strPathAndFile = vntPathAndFileNames
Set wbkMappe = Application.Workbooks.Open(strPathAndFile)
With wbkMappe.ActiveSheet
LZM = .Cells(Rows.Count, 14).End(xlUp).Row
LZZ = wbkZiel.ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
.Range(Cells(2, 14), Cells(LZM, 14)).Copy
wbkZiel.ActiveSheet.Cells(LZZ + 1, 4).PasteSpecial xlPasteValues
Application.CutCopyMode = False
LZM = .Cells(Rows.Count, 12).End(xlUp).Row
LZZ = wbkZiel.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
.Range(Cells(2, 12), Cells(LZM, 12)).Copy
wbkZiel.ActiveSheet.Cells(LZZ + 1, 2).PasteSpecial xlPasteValues
Application.CutCopyMode = False
LZM = .Cells(Rows.Count, 11).End(xlUp).Row
LZZ = wbkZiel.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
.Range(Cells(2, 11), Cells(LZM, 11)).Copy
wbkZiel.ActiveSheet.Cells(LZZ + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
LZM = .Cells(Rows.Count, 9).End(xlUp).Row
LZZ = wbkZiel.ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
.Range(Cells(2, 9), Cells(LZM, 9)).Copy
wbkZiel.ActiveSheet.Cells(LZZ + 1, 7).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End If
wbkMappe.Close False
Application.ScreenUpdating = True
Lass mich wissen, obs Probleme gibt.
Gruss Torsten
|