Schlaufe funktioniert nicht richtig
17.11.2006 11:50:45
Peter
Ich möchte einige Aktionen in meinen hundert Tabellen durchführen, welche die Namen 1 bis 100 haben (handelt sich also nicht um Index-Nummer).
Kann mir jemand sagen, weshalb trotz "for intSheetNr = 1 To 100" die Überträge 100 x im Worksheet 1 vorgenommen werden?
Vielen Dank.
Peter
Option Explicit
Sub Uebertrag()
Dim intSheetNr As Integer
Dim zNr As Long
Dim dblWert(4) As Double
Dim SavePath As String
Dim Tool As String
SavePath = Application.ActiveWorkbook.Path
Tool = ActiveWorkbook.Name
Tool = Left(Tool, Len(Tool) - 4) '.xls wird entfernt
Tool = Tool & "_neu"
Tool = Application.InputBox("Name der neuen Datei eingeben", _
"Tool unter neuem Namen abspeichern", Tool, , , , , 2)
Tool = Application.InputBox("Name der neuen Datei eingeben", "Datei unter neuem Namen abspeichern", Tool, , , , , 2)
If Tool = "False" Then MsgBox "Aktion wurde abgebrochen"
If Tool = "False" Then Exit Sub
If Tool = "" Then MsgBox "Es ist keine Eingabe erfolgt"
If Tool = "" Then Exit Sub
ActiveWorkbook.SaveAs SavePath & "\" & Tool
Range("_L").Value = Range("_A")
For intSheetNr = 1 To 100
With Sheets(intSheetNr)
dblWert(1) = Range("D25").Value
dblWert(2) = Range("E25").Value
dblWert(3) = Range("G25").Value
dblWert(4) = Range("L25").Value
Range("D19").Value = dblWert(1)
Range("E19").Value = dblWert(2)
Range("F19").Value = dblWert(3)
Range("G19").Value = dblWert(4)
Debug.Print intSheetNr
End With
Next intSheetNr
With Sheets("fw_Stichtage")
Range("C6:C19").Value = Range("D6:d19").Value
End With
End Sub