Getrennte Zellen kopieren
23.01.2020 10:14:57
Nepumuk
Hallo,
teste mal:
Option Explicit
Public Sub Import()
Dim objWorkbook As Workbook
Dim objTargetSheet As Worksheet
Dim lngEmptyRow As Long
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Set objTargetSheet = ThisWorkbook.Worksheets("Tabelle1") 'Anpassen !!!
With objTargetSheet
lngEmptyRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
End With
Set objWorkbook = Workbooks.Open(Filename:= _
"D:\XYZ.xlsx", ReadOnly:=True) 'Pfad anpassen !!!
With objWorkbook.Worksheets("Tabelle1") 'Anpassen !!!
Call .Range("F5").Copy(Destination:=objTargetSheet.Cells(lngEmptyRow, 1))
Call .Range("B5").Copy(Destination:=objTargetSheet.Cells(lngEmptyRow, 2))
Call .Range("D5").Copy(Destination:=objTargetSheet.Cells(lngEmptyRow, 3))
Call .Range("F8").Copy(Destination:=objTargetSheet.Cells(lngEmptyRow, 4))
Call .Range("B14:B104").Copy
Call objTargetSheet.Cells(lngEmptyRow, 2).PasteSpecial( _
Paste:=xlPasteAll, Transpose:=True)
End With
Application.CutCopyMode = False
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
Set objTargetSheet = Nothing
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Gruß
Nepumuk