Code 100x laufen lassen und "Werte hochzählen"

Sub hochzählen() Sheets("Testen").Select Cells(1, 1).Select ' in der Zelle steht die Zahl 4933 If Cells(1, 1) > 0 Then Cells(1, 1).Value = Cells(2, 1) + 1 'in der Zelle Cells(2, 1) steht vor (!!!) Ausführung _ ebenfalls 4933 End If ' jetzt ist in Cells (1, 1) der Wert 4934 'jetzt wird die Datei neu gerechnet Calculate ' nachstehende Range ist jetzt die Zeilennummer die in Cells(1, 1) steht = 4934 ' diese erhöht sich jedesmal wenn der Code aktiviert wird ' aber wie kann ich den Wert aus Cells(1, 1) in die Range einbinden? Range("D4934:K4934").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False '---> dieses hochzählen soll jetzt 1100x mal passieren End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' Modul: Modul2 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub hochzählen() Dim lngI As Long On Error GoTo ErrExit With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlManual .DisplayAlerts = False End With With Sheets("Testen") For lngI = 4934 To 6033 .Cells(1, 1) = lngI With .Range(.Cells(lngI, 4), .Cells(lngI, 11)) .Calculate .Value = .Value End With Next End With ErrExit: With Err If .Number <> 0 Then MsgBox "Fehler in Prozedur:" & vbTab & "'hochzählen'" & vbLf & String(60, "_") & _ vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _ "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _ .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _ "VBA - Fehler in Prozedur - hochzählen" .Clear End If End With On Error GoTo 0 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlAutomatic .DisplayAlerts = True .StatusBar = False End With End Sub

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub hochzählen() Dim lngI As Long On Error GoTo ErrExit With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlManual .DisplayAlerts = False End With With Sheets("Testen") For lngI = 4934 To 6033 .Cells(1, 1) = lngI .Calculate With .Range(.Cells(lngI, 4), .Cells(lngI, 11)) .Value = .Value End With Next End With ErrExit: With Err If .Number <> 0 Then MsgBox "Fehler in Prozedur:" & vbTab & "'hochzählen'" & vbLf & String(60, "_") & _ vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _ "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _ .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _ "VBA - Fehler in Prozedur - hochzählen" .Clear End If End With On Error GoTo 0 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlAutomatic .DisplayAlerts = True .StatusBar = False End With End Sub

Sub zufallsblock() Dim vntNumbers As Variant, vntOut(1 To 5, 1 To 6) As Variant, vntRnd(1 To 25) As Variant Dim vntRet As Variant, vntAnswer As Variant Dim lngI As Long, lngR As Long, lngC As Long, lngBlock As Long vntAnswer = Application.InputBox("Wie viele Blöcke?", "Zufall", 1, Type:=1) If vntAnswer CStr(False) And vntAnswer > 0 And vntAnswer

Hallo Erich,
hab den Code angepasst. Damit kannst du beliebig festlegen, aus wie vielen Reihen bzw. Spalten ein Block bestehen soll. Den Bereich mit den Kundennummern musst du ggf. natürlich anpassen.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub zufallsblock()
Dim vntNumbers As Variant, vntOut() As Variant, vntRnd() As Variant
Dim vntRet As Variant, vntAnswer As Variant
Dim lngI As Long, lngR As Long, lngC As Long, lngBlock As Long

'Einstellungen
Const cMaxBlock   As Long = 1000    'Maximale Anzahl an Blöcken
Const cBlockRows  As Long = 4       'Zeilenanzahl eines Blockes
Const cBlockCols  As Long = 7       'Spaltenanzahl eines Blockes (ohne Indexspalte!)

vntAnswer = Application.InputBox("Wie viele Blöcke? (1 bis " & cMaxBlock & ")", "Zufall", 1, Type:=1)

If vntAnswer <> CStr(False) Then
  If vntAnswer > 0 And vntAnswer <= cMaxBlock Then
    vntNumbers = Sheets("Zufallskunden").Range("B2:AH2")  'Bereich mit den Kundennummern!
    
    With Sheets("Tabelle1")
      With .Range(.Cells(2, 1), .Cells(.Rows.Count, cBlockCols + 1))
        .Value = ""
        .Interior.ColorIndex = xlNone
      End With
    End With
    
    Redim vntRnd(1 To UBound(vntNumbers, 2))
    Redim vntOut(1 To cBlockRows, 1 To cBlockCols + 1)
    
    Randomize Timer
    
    For lngBlock = 1 To vntAnswer
      
      For lngI = 1 To UBound(vntNumbers, 2)
        vntRnd(lngI) = Rnd
      Next
      
      lngR = 1
      lngC = 1
      
      For lngI = 1 To UBound(vntNumbers, 2)
        vntRet = Application.Match(Application.Min(vntRnd), vntRnd, 0)
        vntOut(lngR, lngC + 1) = vntNumbers(1, vntRet)
        vntOut(lngR, 1) = lngR + (lngBlock - 1) * cBlockRows
        vntRnd(vntRet) = 99
        lngC = lngC + 1
        If lngI Mod cBlockCols = 0 Then
          lngR = lngR + 1
          lngC = 1
        End If
        If lngR > cBlockRows Or lngC > cBlockCols Then Exit For
      Next
      
      With Sheets("Tabelle1")
        With .Range("A2").Offset((lngBlock - 1) * cBlockRows, 0).Resize(cBlockRows, cBlockCols + 1)
          .Value = vntOut
          .Interior.Color = IIf(lngBlock Mod 2 = 0, RGB(225, 225, 245), RGB(215, 215, 235))
        End With
        .Columns.AutoFit
      End With
    Next
  Else
    MsgBox "Ungültige Eingabe!"
  End If
End If
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Code 100x laufen lassen und "Werte hochzählen"

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

52 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Code 100x laufen lassen und "Werte hochzählen"

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

52 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread