AW: Shaps kopieren
15.07.2003 18:58:47
Tobias
Hallo Knut
Vielen Dank schonmal für deine Hilfe. Leider läuft es bei mir nicht. In Zelle [E9] wird der Sub Name (Shapekopieren) eingetragen. MsgBox reagiert überhaupt nicht und ich möchte den Code gerne in den beigefügten Code CommandButten1_Click() integrieren. Siehe Text im Code.
Private Sub CommandButton1_Click()
Dim Zahl As Variant
Zahl = Val(TextBox1)
If Zahl < 1 Or Zahl > 100 Or Not IsNumeric(TextBox1) Then
MsgBox "Geben Sie bitte eine Zahl zwischen 1 und 100 ein!"
TextBox1.SetFocus
Else
Dim Pfad As String, Quelle As String, Neu1 As String, Neu2 As String, Neu3 As String
Dim Zähler As Integer, Jahr As String
Dim QuellFile As Object, QuellOrdner As Object, Arbeitsmappen As Object
Dim Ordner As String, index As Integer, Jahr1 As String, Tabelle As Worksheet
Dim xlTab As New Excel.Application
Pfad = ThisWorkbook.Path
Quelle = Left(Pfad, Len(Pfad) - 4) & "0000" & "\Stand10000.xls"
Neu1 = ThisWorkbook.Name
Neu2 = Right(Neu1, Len(Neu1) - (Len(Neu1) - 8))
Neu2 = Left(Neu2, Len(Neu2) - 4)
Neu3 = Cells(1, 2)
Application.ScreenUpdating = False
For Zähler = 1 To Zahl
Neu3 = Neu3 + 1
Jahr1 = "Stand" & Neu3 & Neu2
Ordner = ThisWorkbook.Path & "\" & Jahr1 & ".xls"
Set QuellFile = CreateObject("Scripting.FileSystemObject")
Set QuellOrdner = QuellFile.GetFile(Quelle)
QuellOrdner.Copy (Ordner)
xlTab.Workbooks.Open Ordner
For Each Tabelle In xlTab.ActiveWorkbook.Sheets
Tabelle.Name = Left(Tabelle.Name, Len(Tabelle.Name) - 1) & Neu3
Next
xlTab.ActiveWorkbook.Close True
'Shapes (AutoShapes 1) kopieren. AutoShapes 1 ist ein Sechseck das einen Link zu dem oben _
kopierten Workbook "Ordner" haben soll.
'Call Shapekopieren '?????oder wie?????
Next Zähler
Worksheets(1).Select
Cells(1, 2) = Neu3
Application.ScreenUpdating = True
Unload Me
End If
End Sub