معادلة فصل النصف عن الارقام بدءا من حرف معين

[محمد طاهر عرفه]

طلب احد الزملاء طريقة فصل القيم عن الحروف فى ملف اكسيل قام بنسخه من الانترنت ، من هذا الموقع

http://www.priceoftravel.com/595/public-transportation-prices-in-80-worldwide-cities/#

بالمناسبة الملف عن مقارنة لاسعار المواصلات فى عدة دول ، و لا اعلم مدى دقة بياناته

علما بانه بعد النسخ كان طول النص و كذلك طول  القيم مختلف  من خلية لاخرى 

مرفق الملف و به المعادلة ، ربما يحتاجه البعض

الفكرة فى البجث عن مكان حرف ال $  باستخدام دالة  find و تجزيء النص بالطريقة العادية باستخدام دالتي left , right 

 

 

Split PT Prices around the world.rar

[ياسر العربى]

مشكور استاذنا الكريم ا محمد طاهر

ولاثراء الموضوع بالكود والغاء علامة  $ وتحويل القيم الى رقمية لاجراء العمليات الحسابية على المخرجات بكل سهولة

Sub splitText()
    Dim splitVals As Variant
    Dim totalVals As Long
    For Each xx In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
        splitVals = Split(xx.Value, "$")
        totalVals = UBound(splitVals)
        Range(Cells(xx.Row, xx.Column + 1), Cells(xx.Row, xx.Column + 1 + totalVals)).Value = splitVals
    Next
    FIND
    ConvertTextNumberToNumber
End Sub
Sub ConvertTextNumberToNumber()
    On Error Resume Next
    For Each Y In Sheet1.UsedRange.SpecialCells(xlCellTypeConstants)
        If IsNumeric(Y) Then Y.Value = Val(Y.Value)
    Next
End Sub
Sub FIND()
  Range("D:D").Replace What:="–", Replacement:="", LookAt:=xlPart
End Sub

تقبل تحياتي

Split PT Prices around the world.rar

[قلم-الاكسل(عبدالعزيز)]

شكرا للمدير ولاستاذنا طاهر طهرك الله من كل شر

 

[ياسر خليل أبو البراء]

وهذه محاولة أخرى

Sub Test()
    Dim arr, X, I As Long
    
    arr = Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 4).Value
    On Error Resume Next
    For I = LBound(arr, 1) To UBound(arr, 1)
        X = Split(arr(I, 1), "$")
        arr(I, 2) = X(0)
        arr(I, 3) = Replace(X(1), "–", "")
        arr(I, 4) = X(2)
    Next I
    Range("B2").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

 

 

[مختار حسين محمود]

أستاذ محمد

أولا : نشكرك على الموضوع  القيم

ثانيا :  أتمنى أن تطل علينا كل فترة  كده بموضوع  جديد  تحياتى

[omar elhosseini]

 

تحياتي للأخوة الاعزاء

 

Sub Test_1()
'
For x = 2 To Range("B" & Rows.Count).End(3)(1).Row
    vStrings_1 = Split(Cells(x, 2), "$", -1, vbBinaryCompare)
    vStrings_2 = Split(Cells(x, 2), ")", -1, vbBinaryCompare)
    Cells(x, 6) = Trim(vStrings_1(0))
    Cells(x, 7) = Trim(vStrings_2(1))
Next
'
End Sub

 

Split PT Prices around the world_3.rar

 

 

[ياسر خليل أبو البراء]

بارك الله فيك أخي أبو تامر

كود جميل .. بالنسبة للنتائج لا تظهر منضطبة في بعض الأحيان في خلايا معينة وهي التي تكون منفردة (حيث تختفي علامة الدولار)

مثال الصف رقم 3 حيث القيمة 0.17 بينما لم يظهر معها علامة الدولار

 

إليكم حل آخر بدالة معرفة تقوم بجلب نص محدد من داخل الخلية

Function GetElement(Str As String, Delim As String, Ordinal As Long) As Variant
    Dim strTxt() As String
    
    If Len(Str) = 0 Then
        GetElement = CVErr(xlErrNA)
        Exit Function
    End If

    If Len(Delim) > 1 Then
        GetElement = CVErr(xlErrNA)
        Exit Function
    End If

    If InStr(1, Str, Delim) = 0 Then
        GetElement = CVErr(xlErrNA)
        Exit Function
    End If

    If Ordinal <= 0 Then
        GetElement = CVErr(xlErrNA)
        Exit Function
    End If

    If Ordinal > Len(Str) - Len(Replace(Str, Delim, vbNullString)) + 1 Then
        GetElement = CVErr(xlErrNA)
        Exit Function
    End If
    
    strTxt = Split(Str, Delim)
    GetElement = Application.WorksheetFunction.Trim(strTxt(Ordinal - 1))
End Function

استخدام الدالة : استخدم المعادلتين التاليتين :

=GetElement(B2,")",1)&")"

والثانية

=GetElement(B2,")",2)

أما فيما يخص الملف المرفق فأنا لا أرفق ملفات حتى يتعود الأعضاء تطبيق الحلول بأنفسهم .. وذلك لنرتقي ونتعلم

تقبلوا تحياتي

[omar elhosseini]

 

شكرا لك اخي ياسر خليل أبو البراء

انظر الي الصورة واخبرني اين الصف الثالث المنفرد الغير منضبط

فقد يكون جهازك هو الغير منضبط

 

 

 

 

[ياسر خليل أبو البراء]

لقد قمت بتغيير التنسيق لديك  ليكون بالدولار .. أي لابد للكود خاصتك من تغيير تنسيق الخلية ..جرب الكود على أول ملف بالموضوع !!

ولعلمك جهازي منضبط جداً

 

ويمكن للأخوة الأعضاء تجربة الكود وإعطاء آرائهم ..

حكمة اليوم : من تواضع لله رفعه

تقبل تحياتي

 

 

 

 

[omar elhosseini]

 

اخي ياسر خليل أبو البراء

فعلا :

من تواضع لله رفعه

ولكني لا اتعالي  علي احد

ولست افضل من عضو بالمنتدي

فجميعنا سواسية

 

[محمد طاهر عرفه]

السلام عليكم

ما شاء الله ، ابداعات متنوعة و اثراءات  مميزة  للموضوع

أسأل الله ان يديم علينا جميعا التواضع و حب الخير ، و أن يجعلنا من المتحابين فيه ، و الا ينزغ الشيطان بيننا