Zahl 1 mindestens einmal in Spaltenbereich vorkommen lassen

[Colin]

Moin Günther,

danke für deine Antwort! Ich habe jetzt die Makros aktiviert und deinen Code eingefügt und ausgeführt. Dieser hat alle Fälle rot marktiert, in denen die 1 nicht vorkommt. Jetzt muss ich also noch den Teil, der eine der Zahlen außer der 0 ersetzt, einfügen richtig?

Viele Grüße
Colin

[atilla]

Hallo,

ich habe Günthers Code so verändert, dass er noch zusätzlich die Spalte F markiert:

Code:

Sub FindMissingNumber()
 Dim lRow As Long, Status As Boolean
 Dim Ze As Long, rngBlock As Range, c As Range

 With UsedRange
    .Interior.Color = xlNone
    .Font.ColorIndex = xlAutomatic
    .Borders(xlEdgeBottom).LineStyle = xlNone
 End With
 lRow = Cells(Rows.Count, 5).End(xlUp).Row
 For Ze = 2 To lRow Step 4
    Set rngBlock = Range(Cells(Ze, 5), Cells(Ze + 3, 5))
    Status = False
    Range(Cells(Ze + 3, 5), Cells(Ze + 3, 6)).Borders(xlEdgeBottom).Weight = xlMedium
    For Each c In rngBlock
       If CInt(c) = 1 Then
          Status = True
          Exit For
       End If
    Next c
    If Not Status Then
       With rngBlock.Resize(, 2)
          .Interior.Color = rgbLightBlue
          .Font.Color = rgbRed
       End With
    End If
 Next Ze
End Sub

Unten der Code mach dann das, was Du haben möchtest. Günthers Code mit meiner Erweiterung dient lediglich zur optischen Prüfung.
Die Spalte E belasse ich, wie sie ist und schreibe die Ersetzung in Spalte F.

Das ist der Code:

Code:

Sub ersetzen()
Dim lngZ As Long, i As Long, n
Dim ati
Dim lngStelle As Long
Dim boVar As Boolean
lngZ = Cells(Rows.Count, 5).End(xlUp).Row
ati = Range("E2:E" & lngZ)
For i = LBound(ati) To UBound(ati) - 2 Step 4
 n = 0
 Do
 If ati(n + i, 1) = 1 Then
   Exit Do
 End If
 n = n + 1
 Loop Until n = 4
 If n = 4 Then
   Do
   Randomize
   lngStelle = Int((4 * Rnd) + 1)
   Loop Until ati(lngStelle - 1 + i, 1) <> 0
   ati(lngStelle - 1 + i, 1) = 1
 End If
Next i
Range("F2:F" & lngZ) = ati
End Sub

So sieht es dann aus, wenn zuerst Günthers Code und dann mein Code ausgeführt wird:

Arbeitsblatt mit dem Namen 'Seq_Dist_CBC2_CBCPSS_Design'
	A	B	C	D	E	F
25	1	4	4	4	0	0
26	1	5	1	4	0	0
27	1	5	2	2	3	3
28	1	5	3	3	4	4
29	1	5	4	1	2	1
30	1	6	1	2	4	4
31	1	6	2	1	3	3
32	1	6	3	3	2	1
33	1	6	4	4	0	0
34	1	7	1	3	4	4
35	1	7	2	2	2	2
36	1	7	3	4	0	0
37	1	7	4	1	1	1
38	1	8	1	2	1	1
39	1	8	2	1	4	4
40	1	8	3	3	3	3
41	1	8	4	4	0	0
42	1	9	1	1	1	1
43	1	9	2	2	2	2
44	1	9	3	4	0	0
45	1	9	4	3	3	3
46	1	10	1	4	0	0
47	1	10	2	2	4	1
48	1	10	3	1	3	3
49	1	10	4	3	2	2
50	2	1	1	3	4	4

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

Wie gesagt, Günthers Code braucht nicht, der hilft Dir aber bei  der Prüfung der Ergebnisse.

Und hier Deine Datei:  
  Kopie von Seq_Dist_CBC2_CBCPSS_Design_excel.xlsm (Größe: 363,45 KB / Downloads: 8)

[Colin]

Moin Atilla,

vielen Dank für deinen Code! Ich habe die Spalte E durch die von dir erzeugte F ersetzt und die .csv in Sawtooth importiert. Es passt perfekt, das erste Attribut-Level kommt in jedem Task vor. Vielen Dank für die schnelle Hilfe!

Viele Grüße und einen schönen Abend
Colin

[atilla]

Hallo Colin,

zwei Dinge, die keine Auswirkungen auf die Arbeitsweise des Codes haben, kannst Du noch korrigieren.

1.  

Code:

Dim boVar As Boolean

kann gelöscht werden, da nicht genutzt.

2.

Code:

Dim lngZ As Long, i As Long, n

das n am Ende so ersetzen:

Code:

Dim lngZ As Long, i As Long, n As Long

[Colin]

Moin Atilla,

vielen Dank für deine Ergänzungen, ich werde das noch entsprechend anpassen.

Einen schönen Abend noch!
Colin

[atilla]

Hallo Colin,

du hast Deine PN deaktiviert.

Dort hatte ich folgendes geschrieben:

Hallo Colin,

Warum fragst Du nicht im Forum weiter? Das Forum lebt von Fragen und Antworten.
Bitte denk beim nächsten mal daran.
Dein Problem sollte mit Änderung folgender Zeile gelöst werden können:
statt:

Code:

For i = LBound(ati) To UBound(ati) - 4 Step 4

so:

Code:

For i = LBound(ati) To UBound(ati)  Step 4

[snb]

Oder ?

Code:

Sub M_snb()
  sn = Columns(5).SpecialCells(2).Offset(10).SpecialCells(2)
    
  For j = 1 To UBound(sn) Step 4
    If j + 3 > UBound(sn) Then Exit For
    If IsError(Application.Match(1, Application.Index(sn, Evaluate("row(" & j & ":" & j + 3 & ")"), 1), 0)) Then
      For jj = j To j + 3
        If sn(jj, 1) <> 0 Then Exit For
      Next
      sn(jj, 1) = 1
    End If
  Next
    
  Columns(5).SpecialCells(2).Offset(10).SpecialCells(2).Offset(, 2) = sn
End Sub

[snb]

Viel, viel schneller:

Code:

Sub M_snb()
    sn = Columns(5).SpecialCells(2).Offset(9).SpecialCells(2)
    
    For j = 1 To UBound(sn) Step 4
       If j + 3 > UBound(sn) Then Exit For
       If InStr(sn(j, 1) & sn(j + 1, 1) & sn(j + 2, 1) & sn(j + 3, 1), "1") = 0 Then
          For jj = j To j + 3
             If sn(jj, 1) <> 0 Then Exit For
          Next
          sn(jj, 1) = 1
        End If
    Next
    
    Columns(5).SpecialCells(2).Offset(9).SpecialCells(2).Offset(, 2) = sn
End Sub

[Colin]

Moin zusammen,

vielen Dank an Atilla und snb für die Ergänzungen!
Ich habe nun noch ein zweites Conjoint Design, in dem  die "1" in der Spalte E pro Fünferblock einmal vorkommen soll, dieses Mal ab Zeile 2. Dieses Mal gibt es also fünf Konzepte (siehe Spalte C)  von denen eines in Spalte E den Wert "1" annehmen soll. Die Formel soll prüfen, ob in den jeweils fünf Zeilen der Spalte E eine "1" vorkommt. Ist dies nicht der Fall, soll sie eine der fünf Zellen mit "1" überschreiben. Wie gehabt darf dies nicht die "0" sein. Nun gibt es allerdings noch eine weitere Einschränkung: Die überschriebene Zelle der Spalte E darf in der Spalte D derselben Zelle nicht den Wert "4" haben.
Im Anhang findet Ihr die entsprechende Tabelle, ich habe von Zeile 107-111 einen betroffenen Fünferblock gelb markiert. Rot hab ich sowohl die 0 markiert, als auch den Fall, in dem die Spalte D den Wert "4" hat. Falls es die Programmierung erleichtert: Die nicht zu überschreibenden Nullen haben in der Spalte D immer den Wert "5". Mann könnte also auch sagen, dass in der Spalte E nur überschrieben werden darf, was in Spalte D derselben Zeile weder "4" noch "5" ist.

Vielen Dank für Eure Hilfe und einen schönen Sonntag!
Colin

[snb]

Danke !