AW: Inhalt Tabellenblatt kopieren und einfügen
20.02.2014 14:57:10
fcs
Hallo Chris,
im Archiv findet sich sicher das eine oder andere passende Makro für dich.
Hier mal ein Beispiel. Die Namen von Blättern und Datei und vorgegeben Zeilen- und Spaltennumemrn musst du anpassen.
Gruß
Franz
Sub Daten_aktualisieren()
Dim strDatei As String, wkbQuelle As Workbook, wksQuelle As Worksheet
Dim wksZiel As Worksheet, rngZelle As Range
Dim varTabQuelle, varTabZiel
Dim ZeileZiel As Long, ZeileQuelle As Long
If MsgBox("Daten jetzt aktualisieren", vbOKCancel, _
"Daten Importieren") = vbCancel Then Exit Sub
Const ZeileZiel_1 = 3 '1. Zeile mit zu aktualisierenden Daten in Zieldatei
Const Spalte_Z1 As Long = 1 '1. Spalte mit zu aktualisierenden Daten
Const Spalte_ZL As Long = 10 'letzte Spalte mit zu aktualisierenden Daten
Const ZeileQuelle_1 = 2 '1. Zeile mit zu importirenden Daten in Quelldatei
Const Spalte_Q1 As Long = 1 '1. Spalte mit zu importierenden Daten
Const Spalte_QL As Long = 10 'letzte Spalte mit zu importirenden Daten
varTabZiel = "TabelleABX" 'Name oder Indexnummer der Quelltabelle
strDatei = "D:\Test\ImportData.xlsx" 'Name der Quelldatei
varTabQuelle = "TabelleXYZ" 'Name oder Indexnummer der Quelltabelle
If Dir(strDatei) = "" Then
MsgBox "Datei """ & strDatei & """ nicht gefunden!", _
vbOKOnly, "Daten Importieren"
Exit Sub
End If
Application.ScreenUpdating = False
Set wksZiel = ActiveWorkbook.Sheets(varTabZiel)
Set wkbQuelle = Application.Workbooks.Open(strDatei, ReadOnly:=True)
Set wksQuelle = wkbQuelle.Sheets(varTabQuelle)
'Altdaten in Zieltabelle löschen
With wksZiel
Set rngZelle = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
ZeileZiel = ZeileZiel_1 - 1
Else
ZeileZiel = rngZelle.Row
End If
If ZeileZiel >= ZeileZiel_1 Then
.Range(.Cells(ZeileZiel_1, Spalte_Z1), .Cells(ZeileZiel, Spalte_ZL)).ClearContents
End If
End With
'Formate und Daten nach Zieltabelle kopieren
With wksQuelle
Set rngZelle = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
ZeileQuelle = ZeileQuelle_1 - 1
Else
ZeileQuelle = rngZelle.Row
End If
If ZeileQuelle >= ZeileQuelle_1 Then
.Range(.Cells(ZeileQuelle_1, Spalte_Q1), .Cells(ZeileQuelle, Spalte_QL)).Copy
wksZiel.Cells(ZeileZiel_1, Spalte_Z1).PasteSpecial Paste:=xlPasteFormats
wksZiel.Cells(ZeileZiel_1, Spalte_Z1).PasteSpecial Paste:=xlPasteValues
Else
MsgBox "Quelldatei enthält keine Daten"
End If
wkbQuelle.Close savechanges:=False
End With
Cells(ZeileZiel_1, 1).Select
Application.ScreenUpdating = True
End Sub