کد حذف کلمه های بین دو ایتم مورد نظر

[ali.b]

سلام
با اینکد میشه کلماتی که بین دو کلمه firstStr و secondStr مشخص میشن رو پاک کنه

اما من میخوام دقیقا برعکس عمل کنه یعنی هرچی بین firstStr و secondStr هستند رو نگه داره و بقیه رو پاک کنه
ممنون میشم راهنمایی کنید
با تشکر

Sub j()Dim firstStr As String
Dim secondStr As String
Dim Str As String


Dim pos1 As Integer
Dim pos2 As Integer


firstStr = "نام"
secondStr = "صادره"




For i = 1 To 500


    Str = Cells(i, 1) ' here i represents row, and 1 means first column


    pos1 = InStr(UCase(Str), UCase(firstStr))
    pos2 = InStr(UCase(Str), UCase(secondStr))


    If pos1 = 0 Or pos2 = 0 Then
        ' MsgBox "Something goes wrong"
    Else
        StringToDelete = Mid(Str, pos1, pos2 - pos1 + Len(secondStr))
        
        finalString = Replace(Str, StringToDelete, "")
        ' MsgBox finalString
        Cells(i, 1) = finalString
    End If


Next i
End Sub

مثلا به این حالت
کد ملی به نام محمدعلی صادره از ایران

تبدیل بشه به این حالت
محمد علی

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[امين اسماعيلي]

با درود دوست عزیز
شاید اصلا نیازی به کد نداشته باین البته شاید. شما اگر دریت حدس زده باشم به اسم اشخاص که بین نام و صادره قرار دارن نیاز دارین. خب با پیدا کردن مکان نام و صادره در تکست و یکم بازی با فرمول mid میتونین به نتیجه دلخواهتون برسین مثلا اگر همبن عبارت رو در سل K11 نوشته باشیم این فرمول شمار رو باید به نتیجه دلخواه برسونه

=MID(K11,FIND("نام",K11,1)+4,(FIND("صادره",K11,1)-FIND("نام",K11,1))-4-1)

[ali.b]

با درود دوست عزیز
شاید اصلا نیازی به کد نداشته باین البته شاید. شما اگر دریت حدس زده باشم به اسم اشخاص که بین نام و صادره قرار دارن نیاز دارین. خب با پیدا کردن مکان نام و صادره در تکست و یکم بازی با فرمول mid میتونین به نتیجه دلخواهتون برسین مثلا اگر همبن عبارت رو در سل K11 نوشته باشیم این فرمول شمار رو باید به نتیجه دلخواه برسونه

=MID(K11,FIND("نام",K11,1)+4,(FIND("صادره",K11,1)-FIND("نام",K11,1))-4-1)

سلام دقیقا ولی من ی برنام نوشتم که ممکنه 100 تا 150 رنج رو پوشش بده و این کد رو اعمال کنم.دقیقا عین فایل ضمیمه ولی عکس عملکرد اون

[ali.b]

دوستان راه حلی نیست؟

[Ali Parsaei]

سلام،
به فرض براي سل a1 تا a100 از اين کد مي توانيد استفاده کنيد:

[Amir Ghasemiyan]

اگر یکم بخوایم داینامیک تر کنیم به این صورت میشه:

Sub j()
Dim firstStr As String
Dim secondStr As String
Dim Str As String
Dim pos1 As Integer
Dim pos2 As Integer


firstStr = Range("B1").Value
secondStr = Range("B2").Value


For i = 1 To 500
    Str = Cells(i, 1)' here i represents row, and 1 means first column
    pos1 = InStr(UCase(Str), UCase(firstStr))
    pos2 = InStr(UCase(Str), UCase(secondStr))


    If pos1 = 0 Or pos2 = 0 Then
        ' MsgBox "Something goes wrong"
    Else
        finalString = Mid(Str, pos1 + Len(firstStr), Len(Str) - pos2 - Len(secondStr))
        ' MsgBox finalString
        Cells(i, 1) = finalString
    End If
Next i
End Sub

[ali.b]

اگر یکم بخوایم داینامیک تر کنیم به این صورت میشه:

Sub j()
Dim firstStr As String
Dim secondStr As String
Dim Str As String
Dim pos1 As Integer
Dim pos2 As Integer


firstStr = Range("B1").Value
secondStr = Range("B2").Value


For i = 1 To 500
    Str = Cells(i, 1)' here i represents row, and 1 means first column
    pos1 = InStr(UCase(Str), UCase(firstStr))
    pos2 = InStr(UCase(Str), UCase(secondStr))


    If pos1 = 0 Or pos2 = 0 Then
        ' MsgBox "Something goes wrong"
    Else
        finalString = Mid(Str, pos1 + Len(firstStr), Len(Str) - pos2 - Len(secondStr))
        ' MsgBox finalString
        Cells(i, 1) = finalString
    End If
Next i
End Sub

سلام من زدم جواب نداد میشه تو فایل نمونه قرار بدین؟

[Amir Ghasemiyan]

سلام من زدم جواب نداد میشه تو فایل نمونه قرار بدین؟

خدمت شما