تبدیل 10 عبارت به 1 عبارت توسط vb6

[hamalous]

من اين كدها رو نمي زارم كه كپي پيست كنيد بلكه انتظار دارم با توجه به كدهايي كه قرار دادم مشكلتون رو خودتون حل كنيد

كدهاي قبلي رو طوري تغيير دادم تا به طور معكوس عمل كنه،‌اين كار شايد تمام اون چيزي كه مي خواهيد نباشه اما

با كمي فكر كردن روي روش من و تغيير در جزئياتش مي تونيد به هدفتون برسيد

کد php:

Dim Num(100, 1) As String

Open "C:\2.txt" For Input As #1
While EOF(1) = False
    conter = conter + 1
    Input #1, a
    Input #1, b
    Num(conter, 0) = a
    Num(conter, 1) = b
Wend
Close #1
Open "C:\3.txt" For Append As #1
For i = 1 To conter
    TempNum = Left(Num(i, 0), Len(Num(i, 0)) - 1)
    For ii = 0 To 9
        Print #1, TempNum & CStr(ii) & vbTab & CStr(Val(Num(i, 1)) - 1) & "-" & CStr(Val(Num(i, 1)) - 1)
    Next ii
Next i
Close #1 


ممنون دوست عزیز خیلی لطف کردید ببینید دوست عزیز من چیز زیادی نیست شروع کردم به این کار برای همین مهارت شمار رو ندارم در مورد سوال من در پست 17 کد رو قرار دادم فقط نمی تونم شرطی رو که بخوام بنویسم اگه میشه و لطف کنید شرط رو به کد پست 17 اضافه کنید ممنون میشم

[Di Di]

خوب دوست عزيز اين كدهايي كه براي شما گذاشتم خيلي بهتر از اون كد شما عمل مي كنه !!

الگوريتم اون كد چندان مناسب و بهينه نيست ،‌بهتره روي اين روش كار كنيد و اگر مشكلي داره روي اين كد راحت تر مي تونيد

برطرفش كنيد

[hamalous]

خوب دوست عزيز اين كدهايي كه براي شما گذاشتم خيلي بهتر از اون كد شما عمل مي كنه !!

الگوريتم اون كد چندان مناسب و بهينه نيست ،‌بهتره روي اين روش كار كنيد و اگر مشكلي داره روي اين كد راحت تر مي تونيد

برطرفش كنيد

ممنون دوست عزیز عرض کردم خدمتتون من وارد نیستم اگه میشه لطف کنید و یه شرط به همون کد پست 17 اضافه کنید ممنون

[hamalous]

سلام دوستان مشکل من حل شد بابت توجه و لطفتون ممنون من فقط قسمتهایی که آبی کردم رو می خواستم که به کد پست 17 اضافه کنم کد رو قرار می دم شاید به کار کسی بیاد:
Private Sub Command1_Click()
On Error Resume Next
Dim tmp As String
Dim filepath As String
cmdg.ShowOpen
filepath = cmdg.FileName
Open filepath For Input As #1
tmp = Input(LOF(1), #1)
Close #1
out = tmp
Dim i%
Dim x() As String
x = Split(out, vbCrLf)
Dim y() As String, z As String, j As Integer
Dim k As Integer, c As Integer
For i = 0 To UBound(x)
y() = Split(x(i), vbTab)
c = 0
For k = 0 To UBound(x)
If Left(x(k), 4) = Left(x(i), 4) Then
c = c + 1
End If
Next
If c >= 10 Then
z = Left(y(0), 5) + "0" + vbTab + "4-4"
For j = 1 To 9
z = z + vbCrLf + Left(y(0), 5) + CStr(j) + vbTab + "4-4"
Next j
out = Replace(out, x(i), z)
End If
Next i
Text1 = out
Close #1
MsgBox "Done"
End Sub
از مهندس Di Di عزیز بابت کدی که زحمتشو کشیدن سپاسگزارم حتما ازش استفاده می کنم خیلی خیلی ممنون

[hamalous]

بازهم سلام من دو تا سورس که 10عبارت زیر رو :
4-4 123450
4-4 123451
4-4 123452
4-4 123453
4-4 123454
4-4 123455
4-4 123456
4-4 123457
4-4 123458
4-4 123459
تبدیل میکنه به :
5-5 12345
الگوریتم هم به این صورت که رقم آخر اون 10 عبارت حذف و در عوض 1 رقم به ستون دوم اضافه میشه هر دوی این دو تا سورس یک مشکل مشترک دارند و اونم اینه که 10 عبارت باید پشت سرهم باشه تا تبدیل رو انجام بده ،حالا من می خوام اگه 10 عبارت پشت سرهم و مرتب نبود تبدیل انجام بشه دوستان اگه می تونند لطف کنند در این زمینه راهنمایی کنند ممنون

---

بازهم سلام من دو تا سورس که 10عبارت زیر رو :
4-4 123450
4-4 123451
4-4 123452
4-4 123453
4-4 123454
4-4 123455
4-4 123456
4-4 123457
4-4 123458
4-4 123459
تبدیل میکنه به :
5-5 12345
الگوریتم هم به این صورت که رقم آخر اون 10 عبارت حذف و در عوض 1 رقم به ستون دوم اضافه میشه هر دوی این دو تا سورس یک مشکل مشترک دارند و اونم اینه که 10 عبارت باید پشت سرهم باشه تا تبدیل رو انجام بده ،حالا من می خوام اگه 10 عبارت پشت سرهم و مرتب نبود تبدیل انجام بشه دوستان اگه می تونند لطف کنند در این زمینه راهنمایی کنند ممنون

[hamalous]

بازهم سلام من دو تا سورس که 10عبارت زیر رو :
4-4 123450
4-4 123451
4-4 123452
4-4 123453
4-4 123454
4-4 123455
4-4 123456
4-4 123457
4-4 123458
4-4 123459
تبدیل میکنه به :
5-5 12345
الگوریتم هم به این صورت که رقم آخر اون 10 عبارت حذف و در عوض 1 رقم به ستون دوم اضافه میشه
این کد یه مشکل داره و اونم اینه که در برخی مواقع 10 عبارت به صورت زیر هست :
1-4 123450
4-4 123451
4-4 123452
4-4 123453
4-4 123454
4-4 123455
1-4 123456
1-4 123457
4-4 123458
1-4 123459
همانطور که مشاهده می کنید این 10 عبارت ستون دوم یکسانی ندارند و به همین دلیل شرایط تبدیل رو ندارند ولی این کد این عبارات رو تبدیل میکنه حالا من می خوام کد علاوه بر ستون اول ستون دوم رو هم چک کنه که اگه توی 10 عبارت ستون دوم هم یکسان بود عمل تبدیل رو انجام بده ممنون

کد php:

Private Sub Command1_Click()
Dim repeat As Boolean
On Error Resume Next
Dim tmp As String
Dim filepath As String
cmdg.ShowOpen
filepath = cmdg.FileName
Open filepath For Input As #1
tmp = Input(LOF(1), #1)
Close #1
Text1.Text = tmp
   Dim i As Integer, j As Integer
    Dim x() As String, c() As Integer, g() As Integer, y() As String
    Dim n As String, s As String
    x = Split(Text1.Text, vbCrLf)
    ReDim c(0 To UBound(x)), g(0 To UBound(x))
    For i = 0 To UBound(x)
        c(i) = 1
        g(i) = i
    Next
    For i = 0 To UBound(x)
        If Len(x(i)) > 5 Then
            If g(i) = i Or c(g(i)) < 10 Then
                y() = Split(x(i), vbTab)
                n = Left(y(0), Len(y(0)) - 1)
                For j = i + 1 To UBound(x)
                    If Len(x(j)) > 5 Then
                        If n = Left(x(j), Len(n)) Then
                            c(i) = c(i) + 1
                            c(j) = 0
                            g(j) = i
                        End If
                    End If
                Next
                If g(i) = i And c(i) >= 10 Then
                Dim z() As String
                   z = Split(y(1), "-")
    x(i) = n & vbTab & CStr(Val(z(0)) + 1) & "-" & CStr(Val(z(1)) + 1)
                End If
                s = s + x(i) + vbCrLf
            End If
        End If
    Next
out = s
    Dim lines() As String, k As Integer
    lines() = Split(out, vbCrLf)
    For k = 0 To UBound(lines)
        If InStr(Text1.Text, lines(k)) = 0 Then Text2.Text = Text2.Text + lines(k) + vbCrLf
     Next
     Print #2, Text2.Text
End Sub