شمارش حروف

[Hassan2500]

سلام
من ميخوام کد زير تغيير کنه و اين کد کارش اينکه در تکست1 اعداد رو مينويسيم و در تکست2 حروف طبق اون اعداد شمارش ميشن و در تکست3 نوشته ميشن حالا من ميخوام اگه تعداد اعداد تکست1
بيشتر بود دوباره از اول حروف تکست2 شمارش شود و همينطور اگه بيشتر بود باز هم از اول حروف دوباره شمارش شود ولي حروف تکراري نوشته نشود

تکست1: 1 8 3 2
تکست2: ابجدابتث
بايد تکست3 بشه: ا ب ا

در اینجا عدد اول 1 است و حرف اول تکست2 را مينويسيم شد (ا) بعد هشت تا از بعد (ا) شمارديم شد (ا) ولي (ا) را نمينويسيم و (ب) بعدش را مينويسيم چون در بار اول تکرار شده و بعد سه تا از بعد (ب) ميشماريم ميشود (ا) و مينويسيم چون در بار اول تکرار نشده و بعد دوتا از بعد (ا) ميشماريم ميشود (ت)

Private Sub Command1_Click()
Dim i%, a$()
a = Split(Text1, " ")
Text3 = ""
For i = LBound(a) To UBound(a)
a(i) = CInt(a(i))
If i > LBound(a) Then a(i) = a(i) + CInt(a(i - 1))
Text3 = Text3 & Mid(Text2, CInt(a(i)), 1) & " "
Next
End Sub

[just4froum]

بفرمایید :

Private Sub Command1_Click()
Dim x As Long
Dim y As Long
Dim num As Long

Text3.Text = Empty

For x = 1 To Len(Text1.Text)
num = CLng(Mid(Text1.Text, x, 1))
y = y + num
If y > Len(Text2.Text) Then y = y Mod Len(Text2.Text)
Text3.Text = Text3.Text & Mid(Text2.Text, y, 1)

Next x
End Sub

[Hassan2500]

جناب just4froum دستتون درد نکنه فقط یه مشکلیه و اونم اینه که در بار دوم که حروف انتخاب میشن دیگه میخوام حروف تکراری که قبلاً انتخاب شدن دیگه انتخاب نشن اگه میشه درستش کنید

مثال
تکست1: 153
تکست2: ابجد
تکست3: ابج
در اینجا اولین عددمان 1 است (ا) را میگذاریم دومین عدد 5 است (ب) را میگذاریم و سومین عدد 3 است که باید (ا) را بنویسیم ولی چون یکبار انتخاب شده حرف بعدش رو مینویسیم و حرف بعدش که (ب) است هم انتخاب شده پس (ج) را مینویسیم و در اینجا من میخوام حروف تکراری دیگه انتخاب نشن در جایگاهشان

[just4froum]

بفرمایید اینم از کد جدید :

Private Sub Command1_Click()
Dim x As Long
Dim y As Long
Dim num As Long
Dim txt As String
Dim h As String * 1
Dim s As Long

Text3.Text = Empty

For x = 1 To Len(Text1.Text)
num = CLng(Mid(Text1.Text, x, 1))
y = y + num
If y > Len(Text2.Text) Then y = y Mod Len(Text2.Text)
If y = 0 Then y = 1
h = Mid(Text2.Text, y, 1)

If InStr(1, Text3.Text, h) <> 0 Then
txt = Mid(Text2.Text, y + 1) & Mid(Text2.Text, 1, y - 1)
For s = 1 To Len(Text2.Text)
h = Mid(txt, s, 1)
If InStr(1, Text3.Text, h) = 0 Then
Text3.Text = Text3.Text & h
Exit For
End If
Next s

Else
Text3.Text = Text3.Text & h
End If

Next x
End Sub

[Hassan2500]

الآن یه مشکل کوچولو دیگه داره که میخوام حروف در جایگاهشان که تکرار شدند نوشته نشند الآن این کد شما مثلاً وقتی بفرض دو تا (ت) در حروف تکست2 بود دیگه وقتی یکیشون تکرار شد دیگه (ت) دومی رو نمینویسه میخوام بقیه رو بنویسه چون در جایگاهشون تکرار نشدن

مثال
تکست1: 125
تکست: تات
تکست3: تتا

تکست1: 121
تکست2: تات
تکست3: تتا

[محسن واژدی]

سلام علیکم
با اجازه جناب just4froum ،کد زیر را هم بررسی کنید انشاء الله درسته:

Private Sub Command1_Click()
Dim s$(), iNm%, vC, iLastN%, sRes$, sNR$, i

Text3 = Empty
s = Split(Text1, " ")
For Each vC In s
iNm% = CInt(vC)
If iLastN% + iNm% < Len(Text1) Then
iLastN% = iLastN% + iNm%
Else
iLastN% = (iLastN% + iNm%) - Len(Text1)
End If
If iLastN% = 0 Then iLastN% = 1
If Not Mid(Text2, iLastN%, 1) = Mid(sRes$, IIf(Len(sRes$) > 0, Len(sRes$), 1), 1) Then
sRes$ = sRes$ & Mid(Text2, iLastN%, 1)
Else
iLastN% = iLastN% + 1
If iLastN% >= Len(Text2) Then iLastN% = 1
sRes$ = sRes$ & Mid(Text2, iLastN%, 1)
End If
Next
For i = 1 To Len(sRes$)
sNR$ = sNR$ & Mid(sRes$, i, 1) & " "
Next
Text3 = Trim(sNR$)
End Sub


موفق باشید

[Hassan2500]

سلام آقای واژدی کدتون بدرستی کار نمیکنه در ضمن میخوام حروف تکراری در جایگاهی که بودند هم محاسبه نشن

تکست1: 3
تکست2: محمد
تکست3: ح
در صورتی که باید نشون بده
تکست3: م (م: سومین حرف)

یا

تکست1: 432 (بدون فاصله بین اعداد)
تکست2: محمد
تکست3: م
در صورتی که باید نشون بده
تکست3: ح (دومین حرف) م (اولین حرف) م (سومین حرف)

اولین رقم2 است 2تا میشماریم میشود (ح: دومین حرف) دومین رقم3 است از بعد (ح: دومین حرف) 3تا میشماریم میشود (م: اولین حرف) سومین رقم4 است از بعد (م: اولین حرف) 4تا میشماریم دوباره میشود (م: اولین حرف) ولی نمینویسیمش چون قبلاً نوشتیمش حرف بعدش رو هم قبلاً نوشتیم پس (م: سومین حرف) رو مینویسیم

یا

تکست1: 21
تکست2: محمد
تکست3: م
در صورتی که باید نشون بده
تکست3: م م
م (م: اولین حرف) م (م: سومین حرف)

[just4froum]

کد زیر را امتحان کنید :

Private Sub Command1_Click()
Dim a() As String
Dim x As Long
Dim y As Long
Dim num As Long
Dim s As Long


If Text2.Text = Empty Then Exit Sub
Text3.Text = Empty

ReDim a(1 To Len(Text2.Text))

For x = 1 To Len(Text2.Text)
a(x) = Mid(Text2.Text, x, 1)
Next x

For x = 1 To Len(Text1.Text)
num = CLng(Mid(Text1.Text, x, 1))

y = y + num
If y > Len(Text2.Text) Then y = y Mod Len(Text2.Text)
If y = 0 Then y = 1


For s = y To UBound(a)
If a(s) <> Empty Then Text3.Text = Text3.Text & a(s): a(s) = Empty: GoTo NextCh
Next s

For s = 1 To y - 1
If a(s) <> Empty Then Text3.Text = Text3.Text & a(s): a(s) = Empty: GoTo NextCh
Next s

NextCh:
Next x

End Sub

[Hassan2500]

سلام جناب just4froum
کدتون خوبه فقط اینو اصلاح کنید

مثلا بفرض مینویسیم
تکست1: 19
تکست2: ابجده
تکست3: ا ب
در صورتی که باید بشه (حرف تکراری در شمارش حساب میشه ولی نمی نویسیمش)
تکست3: ا ه

[just4froum]

بفرمایید :

Private Sub Command1_Click()
Dim a() As String
Dim x As Long
Dim y As Long
Dim num As Long
Dim s As Long


If Text2.Text = Empty Then Exit Sub
Text3.Text = Empty

ReDim a(1 To Len(Text2.Text))

For x = 1 To Len(Text2.Text)
a(x) = Mid(Text2.Text, x, 1)
Next x

For x = 1 To Len(Text1.Text)
num = CLng(Mid(Text1.Text, x, 1))

y = y + num

Do While y > Len(Text2.Text)
y = y - Len(Text2.Text)
Loop


For s = y To UBound(a)
If a(s) <> Empty Then Text3.Text = Text3.Text & a(s): a(s) = Empty: GoTo NextCh
Next s

For s = 1 To y - 1
If a(s) <> Empty Then Text3.Text = Text3.Text & a(s): a(s) = Empty: GoTo NextCh
Next s

NextCh:
Next x

End Sub

[Hassan2500]

ببین یه برنامه جفر رو دارم مینویسم این کد رو واسه اون میخوام حالا اینم درست کن ممنون میشم
تکست1: 93587
تکست2: مضكصل
تکست3: صضكلم
در صورتی که باید بشه
تکست3: صضكمل

تکست1: 954
تکست2: منتال
تکست3: الت
در صورتی که باید بشه
تکست3: الم

من میخوام تعداد ارقام یا حروف هر چندتا بود درست عمل کنه ولی تا الان برای حروف تکراری که در جایشان تکرار شدن خوب کد نوشتی شمارش میشه اما نوشته نمیشه و حرف بعدش نوشته میشه کدش رو خوب نوشتی

[just4froum]

بفرمایید اینم از برنامه شما که قول داده بودم :

ببینید بازم مشکلی هست یا خیر ؟

Private Sub Command1_Click()
Dim a() As String
Dim x As Long
Dim y As Long
Dim num As Long
Dim s As Long
Dim yy As Long

If Text2.Text = Empty Then Exit Sub

Text3.Text = Empty

ReDim a(1 To Len(Text2.Text))

For x = 1 To Len(Text2.Text)
a(x) = Mid(Text2.Text, x, 1)
Next x

For x = 1 To Len(Text1.Text)
num = CLng(Mid(Text1.Text, x, 1))
y = y + num

Print y
Do While y > Len(Text2.Text)
y = y - Len(Text2.Text)
Print y
Loop

yy = y
y = y - 1
For s = yy To UBound(a)
y = y + 1
If a(s) <> Empty Then Text3.Text = Text3.Text & a(s): a(s) = Empty: GoTo NextCh
Next s
For s = 1 To yy - 1
y = y + 1
If a(s) <> Empty Then Text3.Text = Text3.Text & a(s): a(s) = Empty: GoTo NextCh
Next s

NextCh:
Next x
End Sub

[Hassan2500]

نه دیگه مشکلی نداره فقط من اومدم به این صورت تغییرش دادم ولی برنامه از قسمت :NextCh ایراد میگیره

Private Sub Command1_Click()
Dim a() As String
Dim x As Long
Dim y As Long
Dim num As Long
Dim s As Long
Dim yy As Long

If Text2.Text = Empty Then Exit Sub
Text3.Text = Empty
ReDim a(1 To Len(Text2.Text))
For x = 1 To Len(Text2.Text)
a(x) = Mid(Text2.Text, x, 1)
Next x
For x = 1 To Len(Text1.Text)
num = CLng(Mid(Text1.Text, x, 1))
y = y + num
Print y
Do While y > Len(Text2.Text)
y = y - Len(Text2.Text)
Print y
Loop
yy = y
y = y - 1
For s = yy To UBound(a)
y = y + 1
If a(s) <> Empty Then Text3.Text = Text3.Text & a(s): a(s) = Empty: GoTo NextCh
Next s
For s = 1 To yy - 1
y = y + 1
If a(s) <> Empty Then Text3.Text = Text3.Text & a(s): a(s) = Empty: GoTo NextCh
Next s
NextCh:
Next x


Text4.Text = StrReverse(Text2)
If Text4.Text = Empty Then Exit Sub
Text5.Text = Empty
ReDim a(1 To Len(Text4.Text))
For x = 1 To Len(Text4.Text)
a(x) = Mid(Text4.Text, x, 1)
Next x
For x = 1 To Len(Text1.Text)
num = CLng(Mid(Text1.Text, x, 1))
y = y + num
Print y
Do While y > Len(Text4.Text)
y = y - Len(Text4.Text)
Print y
Loop
yy = y
y = y - 1
For s = yy To UBound(a)
y = y + 1
If a(s) <> Empty Then Text5.Text = Text5.Text & a(s): a(s) = Empty: GoTo NextCh
Next s
For s = 1 To yy - 1
y = y + 1
If a(s) <> Empty Then Text5.Text = Text5.Text & a(s): a(s) = Empty: GoTo NextCh
Next s
NextCh:
Next x
End Sub

[just4froum]

من گذری کدو نگاه کردم دلیلش اینه که شما یکبار بیشتر نمیتونی از NextCh: استفاده کنی ولی در کد دوبار اومده میتونی اینجوری کنی NextCh2:

[Hassan2500]

از NextCh2: استفاده کردم برای قسمت دوم کد ولی برنامه بجوری قفل میکنه و مجبوری حتی ریستارت کنی در ضمن اگه میشه قسمت پرینت روی فرم رو بدارید

[just4froum]

این خط رو به طور کامل حذف کن . ببخشید یادم رفت اونو برای امتحان گذاشته بودم.

Print y

[Hassan2500]

مشکل NextCh: حل نشد حتی از NextCh2: استفاده کردم ولی دوباره ارور میده