|
|
About the Author |
' Generates Patterns P01 thru P70
' Tested with Office 365 under Windows 10Sub Patterns17a() Dim a(81) y = MsgBox("Blocked", vbCritical, "Patterns17a") End n5 = 0: n9 = 0: k1 = 1: k2 = 1 Sheets("Klad1").Select For j1 = 1 To 8 For j2 = j1 + 1 To 8 For j3 = j2 + 1 To 8 For j4 = j3 + 1 To 8 Erase a: a(41) = 1 i1 = j1: GoSub 100 i1 = j2: GoSub 100 i1 = j3: GoSub 100 i1 = j4: GoSub 100 n9 = n9 + 1: GoSub 2650 'Print Patterns Next j4 Next j3 Next j2 Next j1 End ' Define Pattern 100 Select Case i1 Case 1: a(1) = 1: a(9) = 1: a(73) = 1: a(81) = 1 Case 2: a(11) = 1: a(17) = 1: a(65) = 1: a(71) = 1 Case 3: a(21) = 1: a(25) = 1: a(57) = 1: a(61) = 1 Case 4: a(31) = 1: a(33) = 1: a(49) = 1: a(51) = 1 Case 5: a(5) = 1: a(45) = 1: a(77) = 1: a(37) = 1 Case 6: a(14) = 1: a(44) = 1: a(68) = 1: a(38) = 1 Case 7: a(23) = 1: a(43) = 1: a(59) = 1: a(39) = 1 Case 8: a(32) = 1: a(42) = 1: a(50) = 1: a(40) = 1 End Select Return ' Print Patterns 2650 n5 = n5 + 1 If n5 = 6 Then n5 = 1: k1 = k1 + 10: k2 = 1 Else If n9 > 1 Then k2 = k2 + 10 End If Cells(k1, k2 + 1).Select Cells(k1, k2 + 1).Font.Color = -4165632 Cells(k1, k2 + 1).Value = "P" + CStr(n9) i3 = 0 For i1 = 1 To 9 For i2 = 1 To 9 i3 = i3 + 1 Cells(k1 + i1, k2 + i2).Value = a(i3) If a(i3) = 1 Then Cells(k1 + i1, k2 + i2).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.149998474074526 .PatternTintAndShade = 0 End With End If Next i2 Next i1 Return End Sub' Generates Patterns P71 thru P238
Sub Patterns17b() Dim a(81) y = MsgBox("Blocked", vbCritical, "Patterns17b") End n5 = 0: n9 = 0: k1 = 1: k2 = 1 Sheets("Klad1").Select For j1 = 1 To 6 For j2 = 1 To 8 For j3 = j2 + 1 To 8 Erase a: a(41) = 1 i1 = j1: GoSub 200 i1 = j2: GoSub 100 i1 = j3: GoSub 100 n9 = n9 + 1: GoSub 2650 'Print Patterns Next j3 Next j2 Next j1 End ' Define Pattern 100 Select Case i1 Case 1: a(1) = 1: a(9) = 1: a(73) = 1: a(81) = 1 Case 2: a(11) = 1: a(17) = 1: a(65) = 1: a(71) = 1 Case 3: a(21) = 1: a(25) = 1: a(57) = 1: a(61) = 1 Case 4: a(31) = 1: a(33) = 1: a(49) = 1: a(51) = 1 Case 5: a(5) = 1: a(45) = 1: a(77) = 1: a(37) = 1 Case 6: a(14) = 1: a(44) = 1: a(68) = 1: a(38) = 1 Case 7: a(23) = 1: a(43) = 1: a(59) = 1: a(39) = 1 Case 8: a(32) = 1: a(42) = 1: a(50) = 1: a(40) = 1 End Select Return ' Define Pattern 200 Select Case i1 Case 1: a(4) = 1: a(6) = 1: a(36) = 1: a(54) = 1: a(76) = 1: a(78) = 1: a(28) = 1: a(46) = 1: Case 2: a(13) = 1: a(15) = 1: a(35) = 1: a(53) = 1: a(67) = 1: a(69) = 1: a(29) = 1: a(47) = 1: Case 3: a(22) = 1: a(24) = 1: a(34) = 1: a(52) = 1: a(58) = 1: a(60) = 1: a(30) = 1: a(48) = 1: Case 4: a(3) = 1: a(7) = 1: a(27) = 1: a(63) = 1: a(75) = 1: a(79) = 1: a(19) = 1: a(55) = 1: Case 5: a(12) = 1: a(16) = 1: a(26) = 1: a(62) = 1: a(66) = 1: a(70) = 1: a(20) = 1: a(56) = 1: Case 6: a(2) = 1: a(8) = 1: a(18) = 1: a(72) = 1: a(74) = 1: a(80) = 1: a(10) = 1: a(64) = 1: End Select Return ' Print Patterns 2650 n5 = n5 + 1 If n5 = 6 Then n5 = 1: k1 = k1 + 10: k2 = 1 Else If n9 > 1 Then k2 = k2 + 10 End If Cells(k1, k2 + 1).Select Cells(k1, k2 + 1).Font.Color = -4165632 Cells(k1, k2 + 1).Value = "P" + CStr(n9 + 70) i3 = 0 For i1 = 1 To 9 For i2 = 1 To 9 i3 = i3 + 1 Cells(k1 + i1, k2 + i2).Value = a(i3) If a(i3) = 1 Then Cells(k1 + i1, k2 + i2).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.149998474074526 .PatternTintAndShade = 0 End With End If Next i2 Next i1 Return End Sub' Generates Patterns P239 thru P253
Sub Patterns17c() Dim a(81) y = MsgBox("Blocked", vbCritical, "Patterns17c") End n5 = 0: n9 = 0: k1 = 1: k2 = 1 Sheets("Klad1").Select For j1 = 1 To 6 For j2 = j1 + 1 To 6 Erase a: a(41) = 1 i1 = j1: GoSub 200 i1 = j2: GoSub 200 n9 = n9 + 1: GoSub 2650 'Print Patterns Next j2 Next j1 End ' Define Pattern 200 Select Case i1 Case 1: a(4) = 1: a(6) = 1: a(36) = 1: a(54) = 1: a(76) = 1: a(78) = 1: a(28) = 1: a(46) = 1: Case 2: a(13) = 1: a(15) = 1: a(35) = 1: a(53) = 1: a(67) = 1: a(69) = 1: a(29) = 1: a(47) = 1: Case 3: a(22) = 1: a(24) = 1: a(34) = 1: a(52) = 1: a(58) = 1: a(60) = 1: a(30) = 1: a(48) = 1: Case 4: a(3) = 1: a(7) = 1: a(27) = 1: a(63) = 1: a(75) = 1: a(79) = 1: a(19) = 1: a(55) = 1: Case 5: a(12) = 1: a(16) = 1: a(26) = 1: a(62) = 1: a(66) = 1: a(70) = 1: a(20) = 1: a(56) = 1: Case 6: a(2) = 1: a(8) = 1: a(18) = 1: a(72) = 1: a(74) = 1: a(80) = 1: a(10) = 1: a(64) = 1: End Select Return ' Print Patterns 2650 n5 = n5 + 1 If n5 = 6 Then n5 = 1: k1 = k1 + 10: k2 = 1 Else If n9 > 1 Then k2 = k2 + 10 End If Cells(k1, k2 + 1).Select Cells(k1, k2 + 1).Font.Color = -4165632 Cells(k1, k2 + 1).Value = "P" + CStr(n9 + 238) i3 = 0 For i1 = 1 To 9 For i2 = 1 To 9 i3 = i3 + 1 Cells(k1 + i1, k2 + i2).Value = a(i3) If a(i3) = 1 Then Cells(k1 + i1, k2 + i2).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.149998474074526 .PatternTintAndShade = 0 End With End If Next i2 Next i1 Return End Sub
|
|
About the Author |