Count 1-X-2 Before "X" 11th Pos

[Kishan]

Hi,

I need to count in the each row 1, X & 2 before the X is finding in the 11th position (and stop counting if breaks with other sign is found). Example is attached

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1	Year	Date	P1	P2	P3	P4	P5	P6	P7	P8	P9	P10	P11	P12	P13	P14	Empty	Before "X" 11th Position	Before "X" 11th Position	Before "X" 11th Position
2	Year	Date	P1	P2	P3	P4	P5	P6	P7	P8	P9	P10	P11	P12	P13	P14	Empty	Count 1	Count X	Count 2
3	2013	01/12/2013	2	X	2	1	1	1	X	1	1	1	2	X	1	1
4	2013	02/12/2013	2	2	X	1	2	1	X	X	2	1	2	1	2	X
5	2013	03/12/2013	1	1	1	1	1	X	1	X	1	1	X	X	1	2		2
6	2013	04/12/2013	1	1	1	2	1	1	1	2	X	1	1	1	X	1
7	2013	05/12/2013	1	X	1	1	X	1	2	X	1	1	1	1	1	X
8	2013	06/12/2013	1	1	1	2	2	X	1	1	1	X	1	1	1	X
9	2013	07/12/2013	1	1	X	1	1	1	1	2	1	X	1	1	X	1
10	2013	08/12/2013	1	2	1	1	1	1	2	1	1	X	1	1	1	2
11	2013	09/12/2013	2	2	X	2	1	1	2	X	2	1	1	X	1	2
12	2013	10/12/2013	1	1	1	X	1	2	2	1	1	2	1	X	1	1
13	2013	11/12/2013	1	2	1	1	X	1	1	1	1	X	X	1	X	X			1
14	2013	12/12/2013	1	1	2	X	2	2	1	2	X	1	1	X	2	1
15	2013	13/12/2013	1	X	1	X	1	2	2	2	1	1	1	2	2	2
16	2013	14/12/2013	X	X	1	1	2	1	1	2	2	2	X	1	1	1				3
17	2013	15/12/2013	2	2	2	2	2	X	1	1	1	2	X	2	X	1				1
18	2013	16/12/2013	X	1	1	1	X	X	X	1	1	1	X	1	2	2		3
19	2013	17/12/2013	2	2	X	1	2	1	2	1	2	1	X	1	1	X		1
20	2013	18/12/2013	X	1	1	2	1	1	2	1	X	2	X	2	2	1				1
21	2013	19/12/2013	1	1	1	2	1	2	X	2	2	X	1	2	1	1
22	2013	20/12/2013	2	1	1	1	X	2	1	1	X	1	1	1	2	2
Count 1-X-2 Before "X" 11th Pos

Need VBA solution if possible

Please help!

Thanks

Regards,
Kishan

 

[Kishan]

I think this does what you want (it is a modification of the code I gave you earlier where it counts and highlights after the position number and character you specify)...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub CountsBeforeCharacters()
  Dim X As Long, Pos As Long, Count As Long, Cell As Range, Item As String, Char As String
  Pos = Application.InputBox("Which position number (2 through 14)?", Type:=1)
  If Pos >= 2 And Pos <= 14 Then
    Char = InputBox("What character do you want to find prior to?")
    If Application.CountIf(Range("C3:P" & Cells(Rows.Count, "A").End(xlUp)), Char) Then
      With Range("C3:T" & Cells(Rows.Count, "A").End(xlUp))
        .Interior.ColorIndex = xlColorIndexNone
        .Font.ColorIndex = vbBlack
        Intersect(.Rows, Columns("R:T")).ClearContents
      End With
      Columns(2 + Pos).Replace Char, "#N/A", xlWhole
      For Each Cell In Columns(2 + Pos).SpecialCells(xlConstants, xlErrors)
        Cell.Interior.Color = vbYellow
        Item = Cell.Offset(, 1).Value
        Count = 1
        For X = 2 To Pos + 1
          If Cell.Offset(, X) = Item Then
            Count = Count + 1
          Else
            Exit For
          End If
        Next
        With Cell.Offset(, 1).Resize(, X - 1)
          .Interior.ColorIndex = InStr("  1 X 2", Item)
          .Font.Color = vbWhite
        End With
        With Intersect(Cell.EntireRow, Columns("Q").Offset(, InStr("1X2", Item)))
          .Value = Count
          .Interior.ColorIndex = Cell.Offset(, 1).Interior.ColorIndex
          .Font.Color = vbWhite
        End With
      Next
      Columns(2 + Pos).Replace "#N/A", Char, xlWhole
    End If
  End If
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Thank you very much Rick Rothstein,

Both the VBA’s “CountsBeforeCharacters” & “CountsAfterCharacters” are working like a magic

I am very glad and I do appreciate a lot your kind help

Regards,
Kishan

 

[Kishan]

Hi,

I am bit confused I started this thread and got solution of my request as per opening post. After I request for code modification which also I got solved here. Honestly when work go on you come to know you need to be solved also in other way would be more better, request over request which I feel it is too much to ask in the same thread.

My question is do ask here new quiry, when this is solved twice by Rick Rothstein

Or I should open the new thread.

Please guide

Thank you

Regards,
Kishan

 

[Rick Rothstein]

My question is do ask here new quiry, when this is solved twice by Rick Rothstein

Or I should open the new thread.

If the new question is directly related to the thread's question, then you can post it here, otherwise start a new thread. The reason is for starting a new thread when the question is not directly related to the original question is to get more eyes on it. People who are not involved with the current thread (they decided they could not help at the time) won't see your new question whereas if you start a new thread, they will probably look at it and see if they can help or not. Also concerning the fact that I answered your previous two questions... remember that the people answering questions here are all volunteers, so you cannot count on us being available when you ask your next or follow-up questions, nor should you assume any one individual's knowledge of Excel is infinite in scope... while we may be able to provide an answer to one or two of your questions, we might not have a clue as to how to answer a different or distantly related question.

 

[Kishan]

If the new question is directly related to the thread's question, then you can post it here, otherwise start a new thread. The reason is for starting a new thread when the question is not directly related to the original question is to get more eyes on it.

Thank you Rick Rothstein, for you advice, as my query is related to question of this thread I will continue here.

People who are not involved with the current thread (they decided they could not help at the time) won't see your new question whereas if you start a new thread, they will probably look at it and see if they can help or not.

You are correct.

Also concerning the fact that I answered your previous two questions... remember that the people answering questions here are all volunteers

Yes I am really great full to all people are answering and helping voluntarily, and that’s why I feel bad asking again and again giving them troubles I would have thought toughly before asking

so you cannot count on us being available when you ask your next or follow-up questions, nor should you assume any one individual's knowledge of Excel is infinite in scope... while we may be able to provide an answer to one or two of your questions, we might not have a clue as to how to answer a different or distantly related question.

I appreciate you for clarifying my question next time I will precise my query.

Here is my last request to this thread

Could it be possible to count both sides before & after the selected character as shown below?

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X
1	Year	Date	P1	P2	P3	P4	P5	P6	P7	P8	P9	P10	P11	P12	P13	P14	Em	Count Before Char	Count Before Char	Count Before Char	Em	Count After Char	Count After Char	Count After Char
2	Year	Date	P1	P2	P3	P4	P5	P6	P7	P8	P9	P10	P11	P12	P13	P14	Em	1	X	Or 2	Em	1	X	Or 2
3	2013	01/12/2013	2	X	2	1	1	1	X	1	1	1	2	x	1	1
4	2013	02/12/2013	2	2	X	1	2	1	X	X	2	1	2	1	2	X		1				1
5	2013	03/12/2013	1	1	1	1	1	X	1	X	1	1	X	x	1	2
6	2013	04/12/2013	1	1	1	2	1	1	1	2	X	1	1	1	X	1
7	2013	05/12/2013	1	X	1	1	X	1	2	X	1	1	1	1	1	X
8	2013	06/12/2013	1	1	1	2	2	X	1	1	1	X	1	1	1	X				1			1
9	2013	07/12/2013	1	1	X	1	1	1	1	2	1	X	1	1	X	1
10	2013	08/12/2013	1	2	1	1	1	1	2	1	1	X	1	1	1	2
11	2013	09/12/2013	2	2	X	2	1	1	2	X	2	1	1	x	1	2
12	2013	10/12/2013	1	1	1	X	1	2	2	1	1	2	1	x	1	1
13	2013	11/12/2013	1	2	1	1	X	1	1	1	1	X	X	1	X	X
14	2013	12/12/2013	1	1	2	X	2	2	1	2	X	1	1	x	2	1			1					1
15	2013	13/12/2013	1	X	1	X	1	2	2	2	1	1	1	2	2	2
16	2013	14/12/2013	X	X	1	1	2	1	1	2	2	2	X	1	1	1		2				2
17	2013	15/12/2013	2	2	2	2	2	X	1	1	1	2	X	2	X	1				4			1
18	2013	16/12/2013	X	1	1	1	X	X	X	1	1	1	X	1	2	2
19	2013	17/12/2013	2	2	X	1	2	1	2	1	2	1	X	1	1	X		1				1
20	2013	18/12/2013	X	1	1	2	1	1	2	1	X	2	X	2	2	1
21	2013	19/12/2013	1	1	1	2	1	2	X	2	2	X	1	2	1	1
22	2013	20/12/2013	2	1	1	1	X	2	1	1	X	1	1	1	2	2
Count Both Side Of Selecte Char

Please help

Thanks And Regards,
Kishan

 

[Kishan]

Bmpu

 

[Rick Rothstein]

Could it be possible to count both sides before & after the selected character as shown below?

Give this code a try...

[table="width: 500"]
[tr]
	[td]Sub CountsBeforeAndAfterCharacters()
  Dim X As Long, Pos As Long, Count As Long, Cell As Range, Item As String, Char As String
  Pos = Application.InputBox("Which position number (2 through 14)?", Type:=1)
  If Pos >= 2 And Pos <= 14 Then
    Char = InputBox("What character do you want to find prior to?")
    If Application.CountIf(Range("C3:P" & Cells(Rows.Count, "A").End(xlUp)), Char) Then
      With Range("C3:X" & Cells(Rows.Count, "A").End(xlUp))
        .Interior.ColorIndex = xlColorIndexNone
        .Font.ColorIndex = vbBlack
        Intersect(.Rows, Columns("V:X")).ClearContents
      End With
      Columns(2 + Pos).Replace Char, "#N/A", xlWhole
      For Each Cell In Columns(2 + Pos).SpecialCells(xlConstants, xlErrors)
        Cell.Interior.Color = vbYellow
        Item = Cell.Offset(, -1).Value
        Count = 1
        For X = 2 To Pos - 1
          If Cell.Offset(, -X) = Item Then
            Count = Count + 1
          Else
            Exit For
          End If
        Next
        With Cell.Offset(, 1 - X).Resize(, X - 1)
          .Interior.ColorIndex = InStr("  1 X 2", Item)
          .Font.Color = vbWhite
        End With
        With Intersect(Cell.EntireRow, Columns("Q").Offset(, InStr("1X2", Item)))
          .Value = Count
          .Interior.ColorIndex = Cell.Offset(, -1).Interior.ColorIndex
          .Font.Color = vbWhite
        End With
      Next
      For Each Cell In Columns(2 + Pos).SpecialCells(xlConstants, xlErrors)
        Cell.Interior.Color = vbYellow
        Item = Cell.Offset(, 1).Value
        Count = 1
        For X = 2 To Pos + 1
          If Cell.Offset(, X) = Item Then
            Count = Count + 1
          Else
            Exit For
          End If
        Next
        With Cell.Offset(, 1).Resize(, X - 1)
          .Interior.ColorIndex = InStr("  1 X 2", Item)
          .Font.Color = vbWhite
        End With
        With Intersect(Cell.EntireRow, Columns("U").Offset(, InStr("1X2", Item)))
          .Value = Count
          .Interior.ColorIndex = Cell.Offset(, 1).Interior.ColorIndex
          .Font.Color = vbWhite
        End With
      Next
      Columns(2 + Pos).Replace "#N/A", Char, xlWhole
    End If
  End If
End Sub[/td]
[/tr]
[/table]

 

[Kishan]

Give this code a try...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub CountsBeforeAndAfterCharacters()
  Dim X As Long, Pos As Long, Count As Long, Cell As Range, Item As String, Char As String
  Pos = Application.InputBox("Which position number (2 through 14)?", Type:=1)
  If Pos >= 2 And Pos <= 14 Then
    Char = InputBox("What character do you want to find prior to?")
    If Application.CountIf(Range("C3:P" & Cells(Rows.Count, "A").End(xlUp)), Char) Then
      With Range("C3:X" & Cells(Rows.Count, "A").End(xlUp))
        .Interior.ColorIndex = xlColorIndexNone
        .Font.ColorIndex = vbBlack
        Intersect(.Rows, Columns("V:X")).ClearContents
      End With
      Columns(2 + Pos).Replace Char, "#N/A", xlWhole
      For Each Cell In Columns(2 + Pos).SpecialCells(xlConstants, xlErrors)
        Cell.Interior.Color = vbYellow
        Item = Cell.Offset(, -1).Value
        Count = 1
        For X = 2 To Pos - 1
          If Cell.Offset(, -X) = Item Then
            Count = Count + 1
          Else
            Exit For
          End If
        Next
        With Cell.Offset(, 1 - X).Resize(, X - 1)
          .Interior.ColorIndex = InStr("  1 X 2", Item)
          .Font.Color = vbWhite
        End With
        With Intersect(Cell.EntireRow, Columns("Q").Offset(, InStr("1X2", Item)))
          .Value = Count
          .Interior.ColorIndex = Cell.Offset(, -1).Interior.ColorIndex
          .Font.Color = vbWhite
        End With
      Next
      For Each Cell In Columns(2 + Pos).SpecialCells(xlConstants, xlErrors)
        Cell.Interior.Color = vbYellow
        Item = Cell.Offset(, 1).Value
        Count = 1
        For X = 2 To Pos + 1
          If Cell.Offset(, X) = Item Then
            Count = Count + 1
          Else
            Exit For
          End If
        Next
        With Cell.Offset(, 1).Resize(, X - 1)
          .Interior.ColorIndex = InStr("  1 X 2", Item)
          .Font.Color = vbWhite
        End With
        With Intersect(Cell.EntireRow, Columns("U").Offset(, InStr("1X2", Item)))
          .Value = Count
          .Interior.ColorIndex = Cell.Offset(, 1).Interior.ColorIndex
          .Font.Color = vbWhite
        End With
      Next
      Columns(2 + Pos).Replace "#N/A", Char, xlWhole
    End If
  End If
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Thank you Rick Rothstein, for you help once again for the time you spent to solve and giving an ideal solution I appreciate your help

Please could you check?
1-Column R:T does not erase previous data
2-when I enter position 14 data do not present correctly.

Thanks And Regards,
Moti

 

[Kishan]

Thank you Rick Rothstein, I just change "If Pos >= 2 And Pos <= 14 Then" to "If Pos >= 2 And Pos <= 13 Then" and "Intersect(.Rows, Columns("V:X")).ClearContents" to "Intersect(.Rows, Columns("R:X")).ClearContents" and it is working fine.

I appreciate your time and for your great help

Regards,
Kishan

 

[Rick Rothstein]

Thank you Rick Rothstein, I just change "If Pos >= 2 And Pos <= 14 Then" to "If Pos >= 2 And Pos <= 13 Then" and "Intersect(.Rows, Columns("V:X")).ClearContents" to "Intersect(.Rows, Columns("R:X")).ClearContents" and it is working fine.

You are quite welcome. As for the things you had to change... I posted the code just before going to sleep and missed them when I combined to the two codes I had posted previously... I am glad you were able to figure out what needed to be changed on your own (congratulations on being able to do that).

 

[Kishan]

You are quite welcome. As for the things you had to change... I posted the code just before going to sleep and missed them when I combined to the two codes I had posted previously... I am glad you were able to figure out what needed to be changed on your own (congratulations on being able to do that).

Thank you Rick Rothstein, for congratulating to me, tell you the truth when I modified and it worked I felt very happy my self even knowing I did nothing.

You are very generous.

Have a great weekend

Regards,
kishan