Just there is one problem , if D Column has a data it must not replace by the data on I Column .
Just there is one problem , if D Column has a data it must not replace by the data on I Column .
hahahahahaha! Completed!
Hi again!
I've got a new macro concerning my last message I sent you. It deals with my requirements but still some problems that's why I would like help if you don't mind
File : NewCode1
Option Compare Text Sub test() Dim x As String, NbTiret As Variant Dim DernCell As Boolean Application.ScreenUpdating = False Range("B7:B18").Interior.ColorIndex = xlNone x = InputBox("enter one/two number") x = Replace(x, "name", "") NbTiret = Split(x, "-") If UBound(NbTiret) = 1 Then Select Case NbTiret(1) Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12" Range("B7:B" & NbTiret(1) + 6).Interior.Color = RGB(255, 200, 50) 'Orange If UBound(NbTiret) < 12 Then Range("B" & NbTiret(1) + 7 & ":B18").Offset(1,0).Interior.Color = RGB(0, 150, 255) Case Is = "/" Range("B7:B18").Interior.Color = RGB(0, 150, 255) Case Is = "X" Range("B7:B18").Interior.Color = RGB(0, 255, 0) End Select ElseIf UBound(NbTiret) > 1 Then Pos = 0 For i = 0 To UBound(NbTiret) Select Case NbTiret(i) Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12" If NbTiret(i - 1) <> "/" And NbTiret(i - 1) <> "X" And NbTiret(i - 1) <> "" Then Range(Cells(NbTiret(i - 1) + 6, "B"), Cells(NbTiret(i) + 6, "B")).Interior.Color = RGB(255, 200, 50) ElseIf NbTiret(i - 1) <> "/" And NbTiret(i - 1) <> "X" And NbTiret(i - 1) = "" Then Range(Cells(7, "B"), Cells(NbTiret(i) + 6, "B")).Interior.Color = RGB(255, 200, 50) Else Cells(NbTiret(i) + 6, "B").Interior.Color = RGB(255, 200, 50) End If Pos = NbTiret(i) Case Is = "/" Cells(Pos + 7, "B").Interior.Color = RGB(0, 150, 255) Pos = Pos + 1 Case Is = "X" Cells(Pos + 7, "B").Interior.Color = RGB(0, 255, 0) 'Vert Pos = Pos + 1 End Select Next i Else MsgBox "Erreur" Exit Sub End If For i = 8 To 18 If Cells(i - 1, "B").Interior.Color = RGB(255, 200, 50) And Cells(i, "B").Interior.Color = 16777215 Then Cells(i, "B").Interior.Color = RGB(0, 150, 255) ElseIf Cells(i, "B").Interior.Color = 16777215 Then DernCell = True For j = i + 1 To 18 If Cells(j, "B").Interior.Color <> 16777215 Then DernCell = False End If Next j If DernCell = True Then Cells(i, "B").Interior.Color = RGB(0, 150, 255) Else Cells(i, "B").Interior.Color = Cells(i - 1, "B").Interior.Color End If End If Next Range("B19").Interior.Color=VbWhite End Sub
The logic is ok but I prefer your's with the method set c1= Find("name" ...) because if there are several same "name-n", it takes into account
all of these. However, with my new code, if I add some others "name-n", it doesn't work so that's why I'm locked... (File : ProblemNewCode)
Would you be able to give me some help and modify my code or propose a complete new solution ?
Here is a small recap of my requirements => File : Requirements
Thanks
Sorry I didn’t see you’re new message! I was just working on a new code but yours is
much more good! It works perfectly ! You’re so nice thank you very much guy ��
When the end of the input string is "X", it will prompt.
for example: "name-11-X"
This is the modified code.
Private Sub CommandButton1_Click() Dim x$, arr, arr1, i&, j&, mx&, s$, r&, b1 As Boolean, n&, rng As Range Dim O&, G&, B&, Clr& Dim c1 As Range, c2 As Range, mess$, c1a As Range, c2a As Range, s1$, s2$ Retry: x = InputBox("enter one/two number") If x = "" Then MsgBox "you have canceled": Exit Sub O = RGB(255, 200, 50): G = RGB(0, 255, 0): B = RGB(0, 150, 255) Set rng = [a69].CurrentRegion rng.Interior.Color = B arr = rng: mx = Split(arr(UBound(arr), 1), "-")(1) x = Replace(x, "name", 0) arr = Split(x, "-") Do b1 = False If Right(x, 1) = "/" Then x = Left(x, Len(x) - 2) b1 = True End If Loop Until b1 = False If Right(x, 1) = "X" Then x = x & "-" & mx + 1 arr = Split(x, "-") For i = 0 To UBound(arr) s = arr(i) If IsNumeric(s) Then n = n + 1 Else n = 0 If n = 3 Or (s <> "/" And s <> "X" And Not IsNumeric(s)) Then MsgBox "Input error!" GoTo Retry End If Next i ReDim arr1(UBound(arr)) arr1(0) = Array(0, O) For i = 1 To UBound(arr) s = arr(i) If IsNumeric(s) Then arr1(i) = Array(s, O) ElseIf s = "X" Then If IsNumeric(arr(i - 1)) Then arr1(i) = Array(arr(i - 1) + 1, G) Else arr1(i) = Array("?", G) End If Else If IsNumeric(arr(i - 1)) Then arr1(i) = Array(arr(i - 1) + 1, B) Else arr1(i) = Array("?", B) End If End If Next i Do b1 = False For i = 1 To UBound(arr1) - 1 If arr1(i)(0) = "?" Then If arr1(i - 1)(1) = O Then arr1(i)(0) = arr1(i - 1)(0) + 1 b1 = True GoTo 1 End If If arr1(i + 1)(1) = O Then arr1(i)(0) = arr1(i + 1)(0) - 1 b1 = True GoTo 1 End If If arr1(i - 1)(1) = G And IsNumeric(arr1(i - 1)(0)) Then arr1(i)(0) = arr1(i - 1)(0) + 1 b1 = True GoTo 1 End If If arr1(i + 1)(1) = G And IsNumeric(arr1(i + 1)(0)) Then arr1(i)(0) = arr1(i + 1)(0) - 1 b1 = True GoTo 1 End If If arr1(i + 1)(1) = B And IsNumeric(arr1(i + 1)(0)) Then arr1(i)(0) = arr1(i + 1)(0) - 1 b1 = True GoTo 1 End If If arr1(i + 1)(1) = B And IsNumeric(arr1(i - 1)(0)) Then arr1(i)(0) = arr1(i - 1)(0) + 1 b1 = True GoTo 1 End If End If 1 Next i Loop Until b1 = False For i = 0 To UBound(arr1) s1 = "": s2 = "" If i = UBound(arr1) Then If arr1(i)(0) <> mx + 1 Then Clr = O s1 = "name-" & arr1(i)(0) s2 = s1 Else s1 = "" End If Else If arr1(i)(1) = O Then Clr = O If i = 0 Then s1 = "name-1" Else s1 = "name-" & arr1(i)(0) If i = 0 And arr1(i + 1)(1) = B Then s1 = "" If arr1(i + 1)(1) = O Then If i = mx Then s2 = "name-" & mx Else s2 = "name-" & arr1(i + 1)(0) i = i + 1 Else s2 = s1 End If ElseIf arr1(i)(1) = G Then Clr = G s1 = "name-" & arr1(i)(0) If arr1(i + 1)(1) = O Then s2 = "name-" & arr1(i + 1)(0) - 1 ElseIf arr1(i + 1)(1) = G Then For j = i + 1 To UBound(arr1) If arr1(j)(1) <> G Then Exit For Next j s2 = "name-" & arr1(j - 1)(0) i = j - 1 Else s2 = s1 End If End If End If If s1 <> "" And s2 <> "" Then Set c1 = rng.Find(s1, lookat:=xlWhole) Set c2 = rng.Find(s2, lookat:=xlWhole) Set c2a = c2 Do If c2 Is Nothing Then Exit 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 Range(c1, c2a).Interior.Color = Clr Else mess = trans(mess, s1, s2) End If End If Next i If mess <> "" Then MsgBox mess End Sub Function trans(mess, s1, s2) trans = mess & "the range containing ""name-" & s1 & """ & ""name-" & s2 & """ does not exist !!" & vbCrLf End Function
All right no problem!
Hi 大灰狼1976 how are you !?
I come back with the previous code that I would like to change a bit.
Initially, I had name-1 to name-12 from Range("B7") to Range("B18").
But now, if I added name before name-1, do you know how I could I do so that name be taken into account if I enter "name" in my inputbox ?
And then rather than having name-1 to name-12 from Range("B7") to Range("B18"), I would like to get name in Range("B7") and then name-1 in Range("C7") to name-12 in Range("C17"). I tried to set 2 different ranges (1 for name and the other for name-1 to name-12) but it doesn't works
Hi castak!
Sorry I don't quite understand what you mean.
Can you give me an example?
All right here is a file of me new requirements
B7 cell is always orange no matter what input?
Yes that's it!
Done!
Perfect thanks!
Posting Permissions
Reply With Quote
