LinkBack URL
About LinkBacks
Find the strings of only the last digits of the numbers in the 5 sectors, please!
link=http://www.mediafire.com/file/eb42j93sg4n5s4c/pasta_string_hoje.xlsx
Find the strings of only the last digits of the numbers in the 5 sectors, please!
link=http://www.mediafire.com/file/eb42j93sg4n5s4c/pasta_string_hoje.xlsx
So what do you want the result to be?
54 or eb42j93sg4n5s4c
Thanks,
Mike
If you are satisfied with the solution(s) provided, please mark your thread as Solved.
Select Thread Tools-> Mark thread as Solved.
Try this for starters:-
Your data starts "A3",Results start "W3".
Regards Mick
Sub MG15Apr39 Dim Rng As Range, Dn As Range, n As Long, num As Long Dim nstr1 As String, nstr2 As String, nstr3 As String, nstr4 As String, nstr5 As String Set Rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp)) Application.ScreenUpdating = False For Each Dn In Rng ReDim BRay(0 To 100) As Boolean For n = 1 To 20 BRay(Dn(, n).Value) = True Next n For n = 1 To UBound(BRay) If BRay(n) = True Then num = IIf(Len(CStr(n)) = 2, Mid(n, 2), n) Select Case CStr(BRay(n)) Case n < 21: nstr1 = nstr1 & IIf(nstr1 = "", num, ", " & num) Case n < 41: nstr2 = nstr2 & IIf(nstr2 = "", num, ", " & num) Case n < 61: nstr3 = nstr3 & IIf(nstr3 = "", num, ", " & num) Case n < 81: nstr4 = nstr4 & IIf(nstr4 = "", num, ", " & num) Case Else: nstr5 = nstr5 & IIf(nstr5 = "", num, ", " & num) End Select End If Next n Dn.Offset(, 22).Value = nstr1 Dn.Offset(, 23).Value = nstr2 Dn.Offset(, 24).Value = nstr3 Dn.Offset(, 25).Value = nstr4 Dn.Offset(, 26).Value = nstr5 nstr1 = "": nstr2 = "": nstr3 = "": nstr4 = "": nstr5 = "" Next Dn Application.ScreenUpdating = True End Sub
http://www.dec.org.uk/
Ok, MIKE! you, have to sort as was in the example = have put the corresponding colors in the draws, my lottery is 100/20
You have each sector vector the strings, have the option to put new draws the macro go doing as it puts new draws of course
Can you put the planilia in a link, please?
Hello,MICK it's not like that, mick
You have to make each of the 5 colors, only last digit from 0 to 9 the strings
You have to see the strings for each of the 5 sectors. You have to mark the corresponding color in the draw list
Try this:-
NB:- The last Group of numbers has 99 instead of 89 and I've altered the the first "00" to 90
ONLY LAST DIGIT
1 2 3 4 5 6 7 8 9 0
81 82 83 84 85 86 87 88 99 00
91 92 93 94 95 96 97 98 99 00
Regards MickSub MG15Apr22 Private Sub CommandButton2_Click() Dim Rng As Range, Dn As Range, n As Long, num As Long, W As Long, ac As Long Dim RngA As Range, txt As String, Rn As Range, nRng As Range, nStr As String, Hoz As Long Dim nstr1 As String, nstr2 As String, nstr3 As String, nstr4 As String, nstr5 As String Dim Dic As Object Application.ScreenUpdating = False Set RngA = Range("V3:AE4,AG3:AP4,AR3:BA4,BC3:BL4,BN3:BW4") Set Dic = CreateObject("scripting.dictionary") For Each Dn In RngA W = IIf(Dn.Value = "00", 100, Dn.Value) Set Dic(W) = Dn Next Set Rng = Range(Range("A5"), Range("A" & Rows.Count).End(xlUp)) Application.ScreenUpdating = False For Each Dn In Rng ac = 0 ReDim BRay(0 To 100) As Boolean For n = 1 To 20 W = IIf(Dn(, n) = "00", 100, Dn(, n)) BRay(W) = True Next n Dim R As Range For n = 1 To UBound(BRay) If BRay(n) = True Then Set R = Cells(Dn.Row, Dic(n).Column) R = R & IIf(R.Value = "", "x", ",x") End If Next n For Hoz = 1 To 5 Set nRng = Cells(Dn.Row, "V").Resize(, 10).Offset(, ac) ac = ac + 11 For Each Rn In nRng If Rn.Value <> "" Then txt = Replace(Rn.Value, "x", Cells(2, Rn.Column).Value) nStr = nStr & IIf(nStr = "", txt, ", " & txt) End If Next Rn nRng(nRng.Count).Offset(, 1).Value = nStr: nStr = "" Next Hoz Next Dn Application.ScreenUpdating = True End Sub
http://www.dec.org.uk/
Sorry the corret please is 89 90
99 00 error = is corret 89 90
error =Sub MG15Apr22()
Private Sub CommandButton2_Click()
Sub MG15Apr22()
Private Sub CommandButton2_Click()
Hello, MICK please can you put the code in the worksheet? When I try to activate, it shows error
Give this a try
Sub abc() Dim i As Long, ii As Long Dim tmp, sMyStrings, sCols sCols = Array(32, 43, 54, 65, 76) For i = 5 To Cells(Rows.Count, "a").End(xlUp).Row ReDim sMyStrings(4) For ii = 1 To 20 tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",3:3,0)") If VBA.IsNumeric(tmp) Then Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x") Else tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",4:4,0)") Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x") End If Select Case tmp Case Is <= 32 sMyStrings(0) = IIf(sMyStrings(0) = "", Right(Cells(i, ii).Value, 1), sMyStrings(0) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 65535 'Yellow Case Is <= 43 sMyStrings(1) = IIf(sMyStrings(1) = "", Right(Cells(i, ii).Value, 1), sMyStrings(1) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 11892015 'Blue Case Is <= 54 sMyStrings(2) = IIf(sMyStrings(2) = "", Right(Cells(i, ii).Value, 1), sMyStrings(2) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 5287936 'Green Case Is <= 65 sMyStrings(3) = IIf(sMyStrings(3) = "", Right(Cells(i, ii).Value, 1), sMyStrings(3) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 255 'Red Case Is <= 76 sMyStrings(4) = IIf(sMyStrings(4) = "", Right(Cells(i, ii).Value, 1), sMyStrings(4) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 13285804 'Gray End Select Next For ii = LBound(sCols) To UBound(sCols) Cells(i, sCols(ii)) = sMyStrings(ii) Next DoEvents Next MsgBox "Finished" End Sub
excel 2014 Windows 7
Did you change 89 and 90?
error=Else
tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",4:4,0)")
Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x")
End If
YES,MIKE you have to make this correction in the sector,
Logically, 89.90 is correct! Sorry
Also I'm guessing you'll want the strings sorted
Sub abc() Dim i As Long, ii As Long Dim tmp, sMyStrings() As String, sCols 'Application.ScreenUpdating = False sCols = Array(32, 43, 54, 65, 76) For i = 5 To Cells(Rows.Count, "a").End(xlUp).Row ReDim sMyStrings(4) For ii = 1 To 20 tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",3:3,0)") If VBA.IsNumeric(tmp) Then Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x") Else tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",4:4,0)") If VBA.IsNumeric(tmp) Then Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x") End If End If If VBA.IsNumeric(tmp) Then Select Case tmp Case Is <= 32 sMyStrings(0) = IIf(sMyStrings(0) = "", Right(Cells(i, ii).Value, 1), sMyStrings(0) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 65535 'Yellow Case Is <= 43 sMyStrings(1) = IIf(sMyStrings(1) = "", Right(Cells(i, ii).Value, 1), sMyStrings(1) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 11892015 'Blue Case Is <= 54 sMyStrings(2) = IIf(sMyStrings(2) = "", Right(Cells(i, ii).Value, 1), sMyStrings(2) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 5287936 'Green Case Is <= 65 sMyStrings(3) = IIf(sMyStrings(3) = "", Right(Cells(i, ii).Value, 1), sMyStrings(3) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 255 'Red Case Is <= 76 sMyStrings(4) = IIf(sMyStrings(4) = "", Right(Cells(i, ii).Value, 1), sMyStrings(4) & "," & Right(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = 13285804 'Gray End Select End If Next For ii = LBound(sCols) To UBound(sCols) Cells(i, sCols(ii)).Value = BubbleSrt(sMyStrings(ii), True) Next DoEvents Next 'Application.ScreenUpdating = True MsgBox "Finished" End Sub Public Function BubbleSrt(StringIO As String, Ascending As Boolean) Dim ArrayIn As Variant Dim SrtTemp As Variant Dim i As Long Dim j As Long ArrayIn = Split(StringIO, ",") If Ascending = True Then For i = LBound(ArrayIn) To UBound(ArrayIn) For j = i + 1 To UBound(ArrayIn) If ArrayIn(i) > ArrayIn(j) Then SrtTemp = ArrayIn(j) ArrayIn(j) = ArrayIn(i) ArrayIn(i) = SrtTemp End If Next j Next i Else For i = LBound(ArrayIn) To UBound(ArrayIn) For j = i + 1 To UBound(ArrayIn) If ArrayIn(i) < ArrayIn(j) Then SrtTemp = ArrayIn(j) ArrayIn(j) = ArrayIn(i) ArrayIn(i) = SrtTemp End If Next j Next i End If BubbleSrt = Join(ArrayIn, ",") End Function
Try your returned file:-
See sheet2.
Check results that are showing, then remove and run code again to test.
When I change those on your workbook it works fine for me
Hello, mike de best, great, very good job, spectacular
It looks great.
Mike you did the 5 lines, now I'm going to link the 5 columns,
Is to do everything equal, just changed the sectors wait until I put the link
Use the same macro for the 5 columns or sectors
Okay, gonna grab something to eat and walk the dog. Be back shortly
Hello, mike is now only first digit only
Use the same formula or previous macro, so it changes
Now the scan is from the first digit ok.
Do the same, but with the first digit of the number
Option to go putting new draws of course
You should be able to do this, find in the code where it has Right(.....,1) change to Left(.....,1)Originally Posted by jorel
But changed the letters in the new worksheet, changed the reference, is the colors? please
Change out this section of the code
Select Case tmp Case Is <= 32 sMyStrings(0) = IIf(sMyStrings(0) = "", Left(Cells(i, ii).Value, 1), sMyStrings(0) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '65535 'Yellow Case Is <= 43 sMyStrings(1) = IIf(sMyStrings(1) = "", Left(Cells(i, ii).Value, 1), sMyStrings(1) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '11892015 'Blue Case Is <= 54 sMyStrings(2) = IIf(sMyStrings(2) = "", Left(Cells(i, ii).Value, 1), sMyStrings(2) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '5287936 'Green Case Is <= 65 sMyStrings(3) = IIf(sMyStrings(3) = "", Left(Cells(i, ii).Value, 1), sMyStrings(3) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '255 'Red Case Is <= 76 sMyStrings(4) = IIf(sMyStrings(4) = "", Left(Cells(i, ii).Value, 1), sMyStrings(4) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '13285804 'Gray End Select
Sub abc() Dim i As Long, ii As Long Dim tmp, sMyStrings() As String, sCols 'Application.ScreenUpdating = False sCols = Array(32, 43, 54, 65, 76) For i = 5 To Cells(Rows.Count, "a").End(xlUp).Row ReDim sMyStrings(4) For ii = 1 To 20 tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",3:3,0)") If VBA.IsNumeric(tmp) Then Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x") Else tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",4:4,0)") If VBA.IsNumeric(tmp) Then Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x") End If End If If VBA.IsNumeric(tmp) Then Select Case tmp Case Is <= 32 sMyStrings(0) = IIf(sMyStrings(0) = "", Left(Cells(i, ii).Value, 1), sMyStrings(0) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '65535 'Yellow Case Is <= 43 sMyStrings(1) = IIf(sMyStrings(1) = "", Left(Cells(i, ii).Value, 1), sMyStrings(1) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '11892015 'Blue Case Is <= 54 sMyStrings(2) = IIf(sMyStrings(2) = "", Left(Cells(i, ii).Value, 1), sMyStrings(2) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '5287936 'Green Case Is <= 65 sMyStrings(3) = IIf(sMyStrings(3) = "", Left(Cells(i, ii).Value, 1), sMyStrings(3) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '255 'Red Case Is <= 76 sMyStrings(4) = IIf(sMyStrings(4) = "", Left(Cells(i, ii).Value, 1), sMyStrings(4) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '13285804 'Gray End Select End If Next For ii = LBound(sCols) To UBound(sCols) Cells(i, sCols(ii)).Value = BubbleSrt(sMyStrings(ii), True) Next DoEvents Next 'Application.ScreenUpdating = True MsgBox "Finished" End Sub
Last edited by mike7952; 04-15-2017 at 07:26 PM. Reason: Fixed code
error=or ii = LBound(sCols) To UBound(sCols)
Cells(i, sCols(ii)).Value = BubbleSrt(sMyStrings(ii), True)
Must be doing something on your end, works fine for me.
Function not defined compilation error
I didn't post the function with the last code, thinking you would have left the function in the module.
Public Function BubbleSrt(StringIO As String, Ascending As Boolean) Dim ArrayIn As Variant Dim SrtTemp As Variant Dim i As Long Dim j As Long ArrayIn = Split(StringIO, ",") If Ascending = True Then For i = LBound(ArrayIn) To UBound(ArrayIn) For j = i + 1 To UBound(ArrayIn) If ArrayIn(i) > ArrayIn(j) Then SrtTemp = ArrayIn(j) ArrayIn(j) = ArrayIn(i) ArrayIn(i) = SrtTemp End If Next j Next i Else For i = LBound(ArrayIn) To UBound(ArrayIn) For j = i + 1 To UBound(ArrayIn) If ArrayIn(i) < ArrayIn(j) Then SrtTemp = ArrayIn(j) ArrayIn(j) = ArrayIn(i) ArrayIn(i) = SrtTemp End If Next j Next i End If BubbleSrt = Join(ArrayIn, ",") End Function
Mike can not ride, hiker does not have much talent in excel
I will not be able to ride for years.
Lol, So have you got it working now, or you still needing a ride?
Link doesn't drive. You still needing a solution?
But it's another spreadsheet with groups for the columns! Another planilia with the same conditions only changed the groups
This don't work? Color of cell is self adjusting
Sub abc() Dim i As Long, ii As Long Dim tmp, sMyStrings() As String, sCols 'Application.ScreenUpdating = False sCols = Array(32, 43, 54, 65, 76) For i = 5 To Cells(Rows.Count, "a").End(xlUp).Row ReDim sMyStrings(4) For ii = 1 To 20 tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",3:3,0)") If VBA.IsNumeric(tmp) Then Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x") Else tmp = Application.Evaluate("=MATCH(" & Cells(i, ii).Value & ",4:4,0)") If VBA.IsNumeric(tmp) Then Cells(i, tmp).Value = IIf(Cells(i, tmp).Value = "", "x", Cells(i, tmp).Value & ",x") End If End If If VBA.IsNumeric(tmp) Then Select Case tmp Case Is <= 32 sMyStrings(0) = IIf(sMyStrings(0) = "", Left(Cells(i, ii).Value, 1), sMyStrings(0) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '65535 'Yellow Case Is <= 43 sMyStrings(1) = IIf(sMyStrings(1) = "", Left(Cells(i, ii).Value, 1), sMyStrings(1) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '11892015 'Blue Case Is <= 54 sMyStrings(2) = IIf(sMyStrings(2) = "", Left(Cells(i, ii).Value, 1), sMyStrings(2) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '5287936 'Green Case Is <= 65 sMyStrings(3) = IIf(sMyStrings(3) = "", Left(Cells(i, ii).Value, 1), sMyStrings(3) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '255 'Red Case Is <= 76 sMyStrings(4) = IIf(sMyStrings(4) = "", Left(Cells(i, ii).Value, 1), sMyStrings(4) & "," & Left(Cells(i, ii).Value, 1)) Cells(i, ii).Interior.Color = Cells(3, tmp).Interior.Color '13285804 'Gray End Select End If Next For ii = LBound(sCols) To UBound(sCols) Cells(i, sCols(ii)).Value = BubbleSrt(sMyStrings(ii), True) Next DoEvents Next 'Application.ScreenUpdating = True MsgBox "Finished" End Sub Public Function BubbleSrt(StringIO As String, Ascending As Boolean) Dim ArrayIn As Variant Dim SrtTemp As Variant Dim i As Long Dim j As Long ArrayIn = Split(StringIO, ",") If Ascending = True Then For i = LBound(ArrayIn) To UBound(ArrayIn) For j = i + 1 To UBound(ArrayIn) If ArrayIn(i) > ArrayIn(j) Then SrtTemp = ArrayIn(j) ArrayIn(j) = ArrayIn(i) ArrayIn(i) = SrtTemp End If Next j Next i Else For i = LBound(ArrayIn) To UBound(ArrayIn) For j = i + 1 To UBound(ArrayIn) If ArrayIn(i) < ArrayIn(j) Then SrtTemp = ArrayIn(j) ArrayIn(j) = ArrayIn(i) ArrayIn(i) = SrtTemp End If Next j Next i End If BubbleSrt = Join(ArrayIn, ",") End Function
Last edited by mike7952; 04-16-2017 at 07:53 AM.
new link=http://www.mediafire.com/file/s25p175day697kq/string%2Cnova_planilia__columm.xlsx
Code in this link works for me
Click here
new link=http://www.mediafire.com/file/s25p175day697kq/string%2Cnova_planilia__columm.xlsx
Click the button. I guess I'm not understanding your request and why the new links?
k? Color of cell is self adjusting
What's not working now?
OK man! Mike, great job congratulations, works perfect,
Mike, you're great at excel, congratulations, thank you,
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
Register To Reply
Bookmarks