1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
| Sub test()
Dim x$, x1$, rng As Range, arr, O&, G&, B&, i&, clr&
Dim c1 As Range, c2 As Range, mess$, c1a As Range, c2a As Range
Retry:
x = InputBox("enter one/two number") 'sample: name-X-3-6-X-9-/-11-12
If x <> "" Then
O = RGB(255, 200, 50): G = RGB(0, 255, 0): B = RGB(0, 150, 255) 'Replacing color values with variables
Set rng = Sheets("Feuil1").Range("b7:b" & Sheets("Feuil1").[b65536].End(3).Row) 'assign cell area to rng
x = Replace(x, "name-X-/-", "2000-2000,") '**************added line**************
x = Replace(x, "name-/-X-", "-/-X-")
x = Replace(x, "name-/-", "") 'If the beginning is "name-/-" then delete it
'sample: no change happened --> name-X-3-6-X-9-/-11-12
x = Replace(x, "name-X-", ",,") 'sample: name-X-3-6-X-9-/-11-12 --> ,,3-6-X-9-/-11-12
x = Replace(x, "-/-X-", ",1000-1000,")
If x Like ",#*" Then x = Mid(x, 2) '**************added line**************
x = Replace(x, "-X-/-", ",2000-2000,")
x = Replace(x, "name", "1") 'If the beginning is "name-#" then Convert to "1-#"
'sample: no change happened --> ,,3-6-X-9-/-11-12
x = Replace(x, "-/-", ",") 'sample: ,,3-6-X-9-/-11-12 --> ,,3-6-X-9,11-12
x = Replace(x, "-X-", ",,,") 'sample: ,,3-6-X-9,11-12 --> ,,3-6,,,9,11-12
arr = Split(x, ",") 'sample: arr have 7 elements(blank,blank,3-6,blank,blank,9,11-12)
For i = 0 To UBound(arr) 'This cycle is used to transform elements and determine whether input is legal.
If arr(i) <> "" Then
If Not arr(i) Like "*-*" Then arr(i) = arr(i) & "-" & arr(i) 'sample: arr(blank,blank,3-6,blank,blank,9-9,11-12)
If Not IsNumeric(Replace(arr(i), "-", "")) Or Not arr(i) Like "*#-#*" Then
MsgBox "Input Error!": GoTo Retry 'If there is a mistake, start again.
End If
End If
Next i
x = Join(arr, ",") 'sample: ,,3-6,,,9,11-12 --> ,,3-6,,,9-9,11-12
x = Replace(x, "-", ",") 'sample: ,,3-6,,,9-9,11-12 --> ,,3,6,,,9,9,11,12
arr = Split(x, ",") 'sample: arr have 10 elements(blank,blank,3,6,blank,blank,9,9,11,12)
'now, each two elements represent a region. blank means filling green
rng.Interior.Color = B 'set rng color to blue
For i = 0 To UBound(arr) Step 2 'deal with two elements at a time
If arr(i) = "" Then 'if blank then
If i = 0 Then arr(i) = 1 Else arr(i) = arr(i - 1) + 1 'the previous blank = 1 or (the number in front of it + 1)
arr(i + 1) = arr(i + 2) - 1 'the next blank = the number behind it - 1
clr = G 'assign the green value to clr
Else 'if not blank then
If arr(i) = 1000 Then
arr(i) = arr(i + 2) - 1
arr(i + 1) = arr(i)
clr = G
ElseIf arr(i) = 2000 Then
If i = 0 Then
arr(i) = 1
arr(i + 1) = 1
Else
arr(i) = arr(i - 1) + 1
arr(i + 1) = arr(i)
End If
clr = G
Else
clr = O 'assign the orange value to clr
End If
End If
With rng
Set c1 = .Find("name-" & arr(i), lookat:=xlWhole) 'search for existence
Set c1a = c1
Do
If c1a = c1a.Offset(1) Then Set c1a = c1a.Offset(1) Else Exit Do
Loop
Set c2 = .Find("name-" & arr(i + 1), lookat:=xlWhole)
Set c2a = c2
Do
If c2a = c2a.Offset(1) Then Set c2a = c2a.Offset(1) Else Exit Do
Loop
If Not c1 Is Nothing And Not c2 Is Nothing Then 'if exists c1 and c2 then
Range(Range(c1, c1a), Range(c2, c2a)).Interior.Color = clr 'fill the cell area with color, clr has been assigned before
Else 'if not exists c1 or c2 then
mess = trans(mess, arr(i), arr(i + 1)) 'writing information to mess, trans() is custom functions
End If
End With
Set c1 = Nothing: Set c1a = Nothing: Set c2 = Nothing: Set c2a = Nothing
Next i
Else
mess = "you have canceled"
End If
If mess <> "" Then MsgBox mess
End Sub |
Coloriage cellules en fonction de leurs contenus
Répondre avec citation
Partager