i want a unique code of 3 alphanumeric text from a artistic text lines for example
parag PAR
corel8 CR8
coreldraw-x6 CX6
etc
just like the excel example but i need with different characters.
charactet should not be repeat. 3 characters are same then it should take next available character of that word for example
father fat
father fah
father fae
father far
father fth
father fte
father ftr
etc like this nothing else from this.
Put the next code in an Excel module and your 'father' text in column A:A:
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
Option Explicit Private M() As String Sub TestThreeUniqueChar() Dim Interm As Variant, lastRow As Long, strPat As String, El As Variant Dim boolFound As Boolean, i As Long boolFound = False: ReDim M(1) lastRow = ActiveWorkbook.ActiveSheet.Range("A1").End(xlDown).Row Interm = ActiveSheet.Range("A1:A" & lastRow).Value Columns("B:B").Clear For i = 1 To lastRow strPat = Left(Interm(i, 1), 3) For Each El In M() If El = strPat Then boolFound = True: Exit For Next If boolFound = False Then ActiveSheet.Range("B" & i).Value = strPat M(i) = strPat: ReDim Preserve M(i + 1) Else strPat = uniquePattern(Interm(i, 1), strPat, i) End If Next End Sub Function uniquePattern(ByVal strVal As String, strPat As String, i As Long, Optional J As Long) Dim uniqueP As String, boolFound As Boolean, El As Variant If J <= 4 Then J = 4: boolFound = False uniqueP = Left(strPat, 2) & Mid(strVal, J, 1) For Each El In M() If El = uniqueP Then boolFound = True: Exit For Next If boolFound = False Then If Len(uniqueP) = 3 Then ActiveSheet.Range("B" & i).Value = uniqueP M(i) = uniqueP: ReDim Preserve M(i + 1) Else ActiveSheet.Range("B" & i).Value = "Not enough characters" ReDim Preserve M(i + 1) End If Else J = J + 1 If J <= Len(strVal) Then uniquePattern strVal, strPat, i, J Else If Mid(strVal, 4, 1) <> "" Then uniquePattern strVal, Left(strPat, 1) & Right(strPat, 1) & Mid(strVal, 4, 1), i End If End If End If End Function
If you will have a following word not having enough characters to obtain a unique pattern based on your suggested algorithm it will return "Not enough characters" and you will improve the algorithm (adding 1, 2, x, etc) or you will make the pattern manually...
You will obtain something like this:
If you need that code to work in Corel you just need to change the lines 8 and 9 in order to load the list and also the returning sequence, to do that wherever you need.
Is that OK with you?
this is absolutely ok with me butwhat changes i have to made in 8th and 9th if i want to use in corel?i tried with this word "corel draw x6" in excel 2007 with around 51 copies but macro made only unique codes of only 27 letters only then error comes it is showing me a error in excel 2007run time error 28... out of stack spacewhat should i do nowcan we use this in corel directly ?can you share full code of corel draw ?
In that lines the code transfers in an array all the words necessary to be processed. After that everything is the same, except the place where the result must be written. I didn't develop the code to solve an infinite number of cases. Because I considered that it is not necessary. Would you have such a case of more then 27 similar cases of Logo? Or you just wont to annoy people here? Did you try to understand the logic of the code? I would be able to share but I couldn't understand where do you keep the words necessary to be processed and where do you wont to return the resulted patterns (in Corel). I remember you asked a new artistic test having the patterns on its column. I think I have a lot of imagination but I'm still asking myself how will you use it and I didn't want to work like Sisyphus. Besides that I still think i's time for you to learn some VBA and understand what is happening there... If you need only solutions I'm afraid here is not the most appropriate place to ask.
Create an ArtisticTest keeping the Logos and name it "TextX". Copy the next code in a Module and run it:
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
Option Explicit Private M() As String Sub TestThreeUniqueChar() Dim Interm As Variant, strPat As String, El As Variant, s As Shape, strTxt As String Dim boolFound As Boolean, i As Long, left As Double, width As Double, bottom As Double Dim font As Double, height As Double, sPatt As Shape, adjust As Double boolFound = False: ReDim M(1) ActiveDocument.Unit = cdrMillimeter: ActiveDocument.Rulers.HUnits = cdrMillimeter For Each s In ActivePage.Shapes If s.Type = cdrTextShape And s.Name = "TextX" Then left = s.LeftX: width = s.SizeWidth: bottom = s.BottomY font = s.Text.Story.Size: height = s.SizeHeight strTxt = s.Text.Story Interm = Split(strTxt, Chr(13)) adjust = height / (UBound(Interm) + 1) End If If s.Name = "Pattern" Then s.Delete Next For i = 0 To UBound(Interm) strPat = LeftB$(Interm(i), 6) For Each El In M() If El = strPat Then boolFound = True: Exit For Next If boolFound = False Then If sPatt Is Nothing Then Set sPatt = ActivePage.ActiveLayer.CreateArtisticText(left + width + 10, bottom + height - adjust / 3 * 2, strPat, , , , font) sPatt.Name = "Pattern" M(i) = strPat: ReDim Preserve M(i + 1) Else sPatt.Text.Story = sPatt.Text.Story & vbCrLf & strPat M(i) = strPat: ReDim Preserve M(i + 1) End If Else strPat = uniquePattern(Interm(i), strPat, i, sPatt) End If Next End Sub Function uniquePattern(ByVal strVal As String, strPat As String, i As Long, sPatt As Shape, Optional J As Long) Dim uniqueP As String, boolFound As Boolean, El As Variant If J <= 4 Then J = 4: boolFound = False uniqueP = left(strPat, 2) & Mid(strVal, J, 1) For Each El In M() If El = uniqueP Then boolFound = True: Exit For Next If boolFound = False Then If Len(uniqueP) = 3 Then sPatt.Text.Story = sPatt.Text.Story & vbCrLf & uniqueP M(i) = uniqueP: ReDim Preserve M(i + 1) Else sPatt.Text.Story = sPatt.Text.Story & vbCrLf & "Not enough characters" ReDim Preserve M(i + 1) End If Else J = J + 1 If J <= Len(strVal) Then uniquePattern strVal, strPat, i, sPatt, J Else If Mid(strVal, 4, 1) <> "" Then uniquePattern strVal, left(strPat, 1) & Right(strPat, 1) & Mid(strVal, 4, 1), i, sPatt End If End If End If End Function Sub testLeft() Dim x As String Dim Interm As Variant, T As String T = "testare,carare" Interm = Split(T, ",") x = "testare" Debug.Print left(x, 3), LeftB$(x, 6) Debug.Print left(Interm(0), 3) End Sub
Is that OK for you? If yes, how do you intend to use the resulted ArtisticText containing the unique patterns? Just in order not to die stupid...
FaneDuru said:If yes, how do you intend to use the resulted ArtisticText containing the unique patterns?
Some of what paraggoyal has been asking about would appear - to me - to perhaps be related to some of the discussion in this thread.
Although the posts from 2017-09-17 in that thread make it appear as if a specific issue was still unresolved at that point (having two lines for each "index text") , that is not the case. The forum software was so "sick" at that time that we could not reliably post to the main forum, and resolved that issue through private messages.