Excel Workbook nur bestimmte Sheets importieren
Chris
Ich habe aus meinem Excel-Archiv einen Code für ein Makro rausgekramt, mit dem ich per Knopfdruck Tabellenblätter einer anderen Excel-Arbeitsmappe importiere. Das funktioniert auch soweit fast perfekt, aber:
Ziel: Ich drücke einen Button im Tabellenblatt 1, dann wähle ich die Quelldatei aus und es sollen die ersten sechs Tabellenblätter der Quelldatei in die Tabellenblätter 2 bis 7 der Datei mit dem Makro importiert werden. Das passt soweit. Allerdings wird auch das Format und die Spaltenüberschriften der importierten Tabellenblätter in das Tabellenblatt 1 mit dem Button kopiert. Jemand eine Idee, woran das liegt?
Private Sub CommandButton1_Click() 'Knopfdruck auf Button aktualisiert die Tabellenblätter aus _
der Quelldatei
Dim fname As Variant
Dim NewWkb As Workbook ' Definition der Zieldatei (diese Arbeitsmappe)
Dim ImportWkB As Workbook ' Definiton der Quelldatei
Dim ImportWkB2 As Workbook
Dim sh As Variant ' Nummer Tabellenblatt
Dim DestRange As Range ' Ziel-Range
Set NewWkb = ThisWorkbook
fname = Application.GetOpenFilename("Aktuelle Datei Import,*.xls", , "Wähle Datei") ' _
Dialog "Datei öffnen"
If fname False Then
Application.ScreenUpdating = False 'Schaltet Aktualisierung Monitor aus
Set ImportWkB = Workbooks.Open(fname, ReadOnly:=True, UpdateLinks:=0)
For Each sh In ImportWkB.Sheets
NewWkb.Sheets(sh.Index).Cells.UnMerge
Set DestRange = NewWkb.Sheets(sh.Index).Range("A1")
sh.UsedRange.Copy
With DestRange
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
End With
Set DestRange = Nothing
Application.CutCopyMode = False
If sh.Index >= 7 Then Exit For 'only 6 sheets should be imported
Next sh
ImportWkB.Close False
Set ImportWkB = Nothing
End If
Sheets(1).Select 'springt zurück auf Tabellenblatt Home
'speichern der Datei nach Import:
If ActiveWorkbook.Saved = False Then 'If-Schleife zum "Speichern unter" nach dem Update
Dim Neuer_Dateiname
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="Grafik_" & Date & ". _
xls", _
fileFilter:="Excel-Arbeitsmappe, *.xls")
' ActiveWorkbook.Save
If Neuer_Dateiname = False Then Exit Sub
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=xlNormal
MsgBox "Input data updated" 'Meldung über Update erscheint
Else
MsgBox "Input data NOT updated!"
End If
End Sub