Option
Explicit
Sub
extract()
Dim
wbQuelle
As
Workbook
Dim
wsQuelle
As
Worksheet, wsZiel
As
Worksheet
Dim
loSpalte
As
Long
, loLetzteQuelle
As
Long
Dim
i
As
Long
, loEnde
As
Long
, A
As
Integer
A = MsgBox(
"Overwrite existing data with new data?"
, vbYesNo + vbQuestion,
"Import"
)
If
A = vbYes
Then
Application.ScreenUpdating =
False
Set
wbQuelle = Workbooks.Open(
"C:\Users\Dateipfad\Datei.xlsx"
)
Set
wsQuelle = wbQuelle.Worksheets(
"source"
)
Set
wsZiel = ThisWorkbook.Worksheets(
"data"
)
If
wsZiel.UsedRange.Rows.Count > 1
Then
wsZiel.UsedRange.Offset(1, 0).Resize(wsZiel.UsedRange.Rows.Count - 1).ClearContents
End
If
loEnde = wsZiel.Cells(1, wsZiel.Columns.Count).
End
(xlToLeft).Column
For
i = 1
To
loEnde
With
wsQuelle
loSpalte = Application.Match(wsZiel.Cells(1, i), .Rows(1), 0)
loLetzteQuelle = .Cells(.Rows.Count, loSpalte).
End
(xlUp).Row
.Range(.Cells(2, loSpalte), .Cells(loLetzteQuelle, loSpalte)).Copy
wsZiel.Cells(2, i).PasteSpecial xlPasteValues
End
With
Next
i
Application.CutCopyMode =
False
wbQuelle.Close SaveChanges:=
False
wsZiel.Cells(1, 1).
Select
ThisWorkbook.Sheets(
"summary"
).
Select
Set
wbQuelle =
Nothing
:
Set
wsQuelle =
Nothing
:
Set
wsZiel =
Nothing
Application.ScreenUpdating =
True
End
If
End
Sub