AW: Blatt aus externer Datei kopieren und einfügen
05.04.2017 16:32:40
fcs
Hallo Tim,
hier ein Beispiel. Dieses kopiert die Inhalte aus der Quelltabelle in die Zieltabelle.
Einfacher wäre es ggf. das komplette Tabellenblatt aus der Quelle in die Zieldatei zu kopieren.
LG
Franz
'Erstellt unter Excel 2010
Sub Daten_aus_Datei_einfuegen()
Dim wkbQ As Workbook, wksQ As Worksheet
Dim wksZ As Worksheet, wksA As Object
Dim strAdr As String
Application.ScreenUpdating = False
'Zieltabelle setzen
Set wksZ = ActiveWorkbook.Worksheets(4)
'Aktives Blatt merken
Set wksA = ActiveSheet
'Quelldatei öffnen
Set wkbQ = Application.Workbooks.Open( _
Filename:="D:\Sonstiges\Data1.xlsx", _
ReadOnly:=True, _
UpdateLinks:=False) 'Pfad und Dateiname anpassen!!!!
'Quelltabelle setzen
Set wksQ = wkbQ.Worksheets(1)
'Datenbereich in Quelltabelle kopieren
With wksQ
With .UsedRange
strAdr = .Address
.Copy
End With
End With
'Daten in Zieltabelle einfügen
With wksZ.Range(strAdr)
'Spaltenbreiten einfügen
.PasteSpecial Paste:=xlPasteColumnWidths
'Alle daten einfügen
.PasteSpecial Paste:=xlPasteAll
End With
'Quelldatei wieder schliessen
wkbQ.Close savechanges:=False
'gemerktes Blatt aktivieren
wksA.Activate
Application.ScreenUpdating = True
End Sub
'Erstellt unter Excel 2010 - Variante mit Tabellenblatt kopieren
Sub Tabellenblatt_aus_Datei_einfuegen()
Dim wkbQ As Workbook, wksQ As Worksheet
Dim wkbZ As Workbook, wksA As Object
Application.ScreenUpdating = False
'Zieldatei setzen
Set wkbZ = ActiveWorkbook
'Aktives Blatt merken
Set wksA = ActiveSheet
'Quelldatei öffnen
Set wkbQ = Application.Workbooks.Open( _
Filename:="D:\Sonstiges\Data1.xlsx", _
ReadOnly:=True, _
UpdateLinks:=False) 'Pfad und Dateiname anpassen!!!!
'Quelltabelle setzen
Set wksQ = wkbQ.Worksheets(1)
'Quelltabelle in Zieldatei kopieren
wksQ.Copy after:=wkbZ.Sheets(3)
'kopiertes Blatt umbenennen
wkbZ.Sheets(4).Name = "Test" & Format(Now, "YYYYMMDDhhmmss") 'Name anpassen
'Quelldatei wieder schliessen
wkbQ.Close savechanges:=False
'gemerktes Blatt aktivieren
wksA.Activate
Application.ScreenUpdating = True
End Sub