Thema Datum  Von Nutzer Rating
Antwort
11.09.2021 08:46:16 Stephan
NotSolved
11.09.2021 09:39:54 Gast92223
NotSolved
11.09.2021 10:43:32 Stephan
NotSolved
11.09.2021 13:28:27 xlKing
NotSolved
11.09.2021 17:20:10 Stephan
NotSolved
11.09.2021 18:14:09 xlKing
NotSolved
11.09.2021 18:54:39 Stephan
NotSolved
11.09.2021 19:42:40 xlKing
NotSolved
11.09.2021 21:02:08 Stephan
NotSolved
11.09.2021 22:26:30 xlKing
*****
NotSolved
12.09.2021 09:19:03 Stephan
NotSolved
13.09.2021 17:06:36 Stephan
NotSolved
14.09.2021 18:12:43 xlKing
NotSolved
Blau Werte in Bestimmte Bereiche kopieren nach Bedinung
14.09.2021 19:06:13 xlKing
NotSolved
14.09.2021 19:28:36 xlKing
NotSolved
14.09.2021 22:23:27 Stephan
NotSolved
15.09.2021 00:56:58 xlKing
NotSolved
18.09.2021 17:43:35 Stephan
NotSolved
18.09.2021 22:10:30 xlKing
*****
NotSolved
19.09.2021 14:28:22 Stephan
NotSolved
11.09.2021 16:57:11 Mase
NotSolved

Ansicht des Beitrags:
Von:
xlKing
Datum:
14.09.2021 19:06:13
Views:
467
Rating: Antwort:
  Ja
Thema:
Werte in Bestimmte Bereiche kopieren nach Bedinung

Oder hab ich dich falsch verstanden und du willst nicht die ersten 6 Y-Werte des Quelltabellenblatts sondern zufällig ausgewählte 6 Werte aus den vorhandenen Y-Werten in das Ziel kopieren? Dann versuch mal diesen Code:

Sub CommandButton2_Click()
  
  Dim yarr(), parr()
  
  Randomize Timer
  
  Set Quelle = Sheets("FCLM_Data")
  Set ziel = Sheets("Board")
  ziel.Cells.ClearContents
  
  z2 = 9: s2 = 3: z3 = 9: s3 = 12: z4 = 13: s4 = 12: ymax = 6: pmax = 2
  
  yvorh = Application.WorksheetFunction.CountIf(Quelle.Columns(13), "y")
  pvorh = Application.WorksheetFunction.CountIf(Quelle.Columns(13), "p")
  
  ReDim yarr(yvorh, 2)
  ReDim parr(pvorh, 2)
  
  For z1 = 1 To Quelle.Cells(Rows.Count, 1).End(xlUp).Row
    If s2 > 10 Then
      s2 = 3
      z2 = z2 + 2
    End If
    
    If Quelle.Cells(z1, 1) <> "" Then
      If Quelle.Cells(z1, 13) = "y" Then
         y = y + 1
         yarr(y, 1) = Quelle.Cells(z1, 1)
      ElseIf Quelle.Cells(z1, 13) = "p" Then
        p = p + 1
        parr(p, 1) = Quelle.Cells(z1, 1)
      Else
        ziel.Cells(z2, s2) = Quelle.Cells(z1, 1)
        s2 = s2 + 1
      End If
    End If
  Next z1
   
  For i = 1 To ymax
    Do
    zufall = Int(Rnd * UBound(yarr, 1)) + 1
    Loop Until yarr(zufall, 2) = ""
    yarr(zufall, 2) = "gezogen"
    
    If s3 > 18 Then
      s3 = 12
      z3 = z3 + 2
    End If
    ziel.Cells(z3, s3) = yarr(zufall, 1)
    s3 = s3 + 1
  Next i
   
  For i = 1 To pmax
    Do
    zufall = Int(Rnd * UBound(parr, 1)) + 1
    Loop Until parr(zufall, 2) = ""
    parr(zufall, 2) = "gezogen"
    
    If s4 > 18 Then
      s4 = 12
      z4 = z4 + 2
    End If
    ziel.Cells(z4, s4) = parr(zufall, 1)
    s4 = s4 + 1
  Next i
   
End Sub

Gruß Mr. K.


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
11.09.2021 08:46:16 Stephan
NotSolved
11.09.2021 09:39:54 Gast92223
NotSolved
11.09.2021 10:43:32 Stephan
NotSolved
11.09.2021 13:28:27 xlKing
NotSolved
11.09.2021 17:20:10 Stephan
NotSolved
11.09.2021 18:14:09 xlKing
NotSolved
11.09.2021 18:54:39 Stephan
NotSolved
11.09.2021 19:42:40 xlKing
NotSolved
11.09.2021 21:02:08 Stephan
NotSolved
11.09.2021 22:26:30 xlKing
*****
NotSolved
12.09.2021 09:19:03 Stephan
NotSolved
13.09.2021 17:06:36 Stephan
NotSolved
14.09.2021 18:12:43 xlKing
NotSolved
Blau Werte in Bestimmte Bereiche kopieren nach Bedinung
14.09.2021 19:06:13 xlKing
NotSolved
14.09.2021 19:28:36 xlKing
NotSolved
14.09.2021 22:23:27 Stephan
NotSolved
15.09.2021 00:56:58 xlKing
NotSolved
18.09.2021 17:43:35 Stephan
NotSolved
18.09.2021 22:10:30 xlKing
*****
NotSolved
19.09.2021 14:28:22 Stephan
NotSolved
11.09.2021 16:57:11 Mase
NotSolved