Tabellen kopieren
20.12.2008 22:53:40
edie
nach stundenlanger Recherche habe ich nachfolgenden Code gefunden, den ich versuche anzupassen. Ohne Erfolg.
Ich würde gerne aus einer Arbeitsmappe Tabellen in eine andere Arbeitsmappe kopieren. Dabei werden die Tabellen in eine ListBox eingelesen.
Mit sFile = Application.GetOpenFilename("Excel-Arbeitsmappen (*.xls), *.xls") möchte
ich gerne die Arbeitsmappe wählen in die die Tabellen kopiert werden sollen.
Leider funktioniert das kopieren nicht und ich weis auch nicht voran es liegt.
Private Sub cmdOK_Click()
Dim arr() As String
Dim iRow As Integer, iCounter As Integer
Dim wkb As Workbook
Dim sFile As String
Application.ScreenUpdating = False
sFile = Application.GetOpenFilename("Excel-Arbeitsmappen (*.xls), *.xls")
If Dir(sFile) = "" Then
Beep
MsgBox "Datei wurde nicht gefunden!"
Exit Sub
End If
On Error GoTo ERRORHANDLER
Application.EnableEvents = False
For iRow = 0 To lstSheets.ListCount - 1
If lstSheets.Selected(iRow) Then
iCounter = iCounter + 1
ReDim Preserve arr(1 To iCounter)
arr(iCounter) = Worksheets(lstSheets.List(iRow)).Name
End If
Next iRow
Set wkb = Workbooks.Open(sFile, False)
'ActiveWorkbook.Close
With ThisWorkbook
'Worksheets(arr).Copy after:=Workbooks("test.xls"). _
Sheets(1)
Worksheets(arr).Copy after:=.wkb.Worksheets(.Worksheets.Count)
End With
'wkb.Close savechanges:=True
ERRORHANDLER:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Initialize()
Dim i As Integer
For i = 2 To Worksheets.Count
lstSheets.AddItem Worksheets(i).Name
Next i
End Sub
Hat jemand eine Idee und kann helfen?
Vielen Dank im Voraus.
Grüße