المساعد في كود

ع_ حسام · نوفمبر 24, 2015

السلام عليكم

طلب مساعدة من خبراء الأكواد على كود بدل معادلة kaled.ra.rar

ياسر خليل أبو البراء · نوفمبر 24, 2015

أخي الكريم حسام

يفضل ذكر مثال واحد من الأمثلة الموجودة وشرحها مرة أخرى بالتفصيل مع ذكر شكل النتائج المتوقعة ...

تقبل تحياتي

ع_ حسام · نوفمبر 24, 2015

شكرا لك الأستاذ ياسر على سرعة الرد

السطر الأول الخاص يالبنك

والسطر الثاني خاص بالعميل الأول أي كل عميل له سطر حسب معطياته الخاصة به data

ياسر خليل أبو البراء · نوفمبر 24, 2015

أكرر أخي الكريم ما هي شكل النتائج المتوقعة ؟؟ ما هي البيانات المراد استخراجها بالتفصيل ..؟

ويرجى ذكر مثال بالشرح ها هنا وليس في ملف مرفق ..

**الـعيدروس** · نوفمبر 25, 2015

Sub Ali_Tv()
Dim r1, r2, r3, r4, r5, r6
Dim i1, i2, i3, i4
Dim Rw
Dim n1, n2, n3, n4, n5, n6
Dim t1, t2, t3, t4
Dim X, XX, Xl_Ali, Bm
Dim Fil_Nm As Integer
Dim Pth As String
Dim Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2")
'****************************
Const Sr = 8: Const Bnk = 10
Const Tol = 13: Const Cus = 7
Const Ky = 2: Const Nm = 27
'=======================================================================================
With Sh1
          r1 = CStr(.[B5]): r2 = CStr(.[E5]): r3 = CStr(.[B6])
          r3 = IIf(InStr(1, r3, ".") <> 0, Replace(r3, ".", ""), r3)
          r4 = CStr(.[B7]): r5 = CStr(.[B8]): r6 = CStr(.[D8])
          If Len(r1) < Bnk Then
               i1 = String((Bnk - Len(r1)), "0") & r1
            Else
               i1 = r1
          End If
          If Len(r2) < Ky Then
               i2 = String((Ky - Len(r2)), "0") & r2
             Else
               i2 = r2
          End If
          If Len(r3) < Tol Then
               i3 = String((Tol - Len(r3)), "0") & r3
             Else
               i3 = r3
          End If
          If Len(r4) < Cus Then
               i4 = String((Cus - Len(r4)), "0") & r4
             Else
               i4 = r4
          End If
          X = "*" & String(Sr, "0") & i1 & i2 & i3 & i4 & r5 & r6 & String(14, " ") & "0"
'=======================================================================================
For Rw = 13 To .[A12].End(xlDown).Row
     If Not .Cells(Rw, 1) = Empty Then
'=======================================================================================
        n1 = CStr(.Cells(Rw, 4)): n2 = CStr(.Cells(Rw, 5)): n3 = CStr(.Cells(Rw, 6))
        n3 = IIf(InStr(1, n3, ".") <> 0, Replace(n3, ".", ""), n3)
        n4 = CStr(UCase(.Cells(Rw, 2))): n5 = CStr(UCase(.Cells(Rw, 3)))
        If Len(n1) < Bnk Then
                t1 = String((Bnk - Len(n1)), "0") & n1
           Else
                t1 = n1
        End If
        If Len(n2) < Ky Then
                t2 = String((Ky - Len(n2)), "0") & n2
           Else
                t2 = n2
        End If
             n3 = Format(n3, "0.00"): n3 = Replace(n3, ".", "")
        If Len(n3) < Tol Then
                t3 = String((Tol - Len(n3)), "0") & n3
           Else
                t3 = n3
        End If
        If (Len(n4 & " ") + Len(n5)) < Nm Then
                t4 = n4 & " " & n5 & String((Nm - (Len(n4 & " ") + Len(n5))), " ")
           Else
                t4 = n4 & " " & n5
        End If
        XX = XX & "*" & String(Sr, "0") & t1 & t2 & t3 & t4 & "1" & vbNewLine
'=======================================================================================
     End If
Next Rw
End With
'---------------------------
Xl_Ali = X & vbNewLine & XX
'------------------------------------------------------------------------------
Bm = Split(Xl_Ali, vbNewLine): Sh2.Range("A1").Resize(UBound(Bm)) = Application.Transpose(Bm)
'---------------------------
Fil_Nm = FreeFile
'------------------------------------------------------------------------------
Pth = ThisWorkbook.Path & "\" & "Disq" & " " & r5 & r6 & ".txt"
'------------------------------------------------------------------------------
Open Pth For Output As #Fil_Nm
'---------------------------
Print #Fil_Nm, Xl_Ali
'---------------------------
Close #Fil_Nm
'---------------------------
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub

جرب الكود هذا ان شاء الله يعمل بالشكل الذي تريد

ملف التكست سيحفظه بنفس فولدر ملف الاكسل

تحياتي

تم تعديل نوفمبر 25, 2015 بواسطه الـعيدروس

ع_ حسام · نوفمبر 25, 2015

السلام عليكم أستاذ العيدروس كود ممتاز وصحيح يشبه أكواد الأستاذ عبد الله بقشير

أتمنى أين يكون في الصحة وعافية شكرا لك ،

إلا أنه في خطأ بسيط وهوكمايلي

1 أنه المبلغ في كلتا الحالتين يكتب بدون فاصلة

2 عدد 13 و ليس 12 لاحظ الكود

يعمل هكذا 0000640863,75 وعدد الأرقام 12 وليس 13كما هو مطلوب أي أنه يحسب الفاصلة

عوضا هكذا 0000064086375 وهو الصحيح

أنا عملتها بالمعادلات هكذا REPT("0";13-LEN(Sheet1!B6*100))&Sheet1!B6*100

ضربت في 100 لتخلص من الفاصلة و لأن الدالة LEN لن تحسب الأرقام العشرية إذكانت اصفار مثلا 156.00 هناك 5أعداد فتطي 3 فقط

أتمنى أن تكون الفكرة وصلت

**الـعيدروس** · نوفمبر 25, 2015

اقتباس

*000000000000124578210000000003400000MAROUN HOSAME 1

لاحظ السطر الثاني في مثالك 9 اصفار لماذا

والذي شرحت انت ان يكون العدد الكلي للرصيد هو

اقتباس

مبلغ الرصيد يحتوي على 13 رقم بما فيها العشرات

الصحيح يكون هكذا

اقتباس

000000000000124578210000003400000MAROUN HOSAME

ارجوا توضيح النتائج المرجوه لان هذا الذي لخبط دماغي

شرحك غير النتائج

تم تعديل نوفمبر 25, 2015 بواسطه الـعيدروس

ع_ حسام · نوفمبر 25, 2015

الأستاذ العيدروس فعلا كلامك صحيح

لأن الدالة len هي التي تسببت في الخطأ كما ذكرة لك سابقا ولخبطك معايا لأني لم أنتبه للخطأ إلا بعد المقارنة والمراجعة مع الكود

كما توجد إظافة وهي ان العمل ينتهي بسهم صغير يعبر على إنتهاء القائمة

المرفق عيدروس.rar

تم تعديل نوفمبر 25, 2015 بواسطه ع_ حسام

**الـعيدروس** · نوفمبر 25, 2015

تفضل

Sub Ali_Tv()
Dim r1, r2, r3, r4, r5, r6
Dim i1, i2, i3, i4
Dim Rw
Dim n1, n2, n3, n4, n5, n6
Dim t1, t2, t3, t4
Dim X, XX, Xl_Ali, Bm, Ibn1, Ibn11
Dim Fil_Nm As Integer
Dim Pth As String
Dim Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2")
'****************************
Const Sr = 8: Const Bnk = 10
Const Tol = 13: Const Cus = 7
Const Ky = 2: Const Nm = 27
'=======================================================================================
With Sh1
          Ibn = IIf(InStr(1, CStr(.[B6]), ".") <> 0, Val(.[B6] * 100), CStr(.[B6]))
          r1 = CStr(.[B5]): r2 = CStr(.[E5]): r3 = Val(Ibn)
          r4 = CStr(.[B7]): r5 = CStr(.[B8]): r6 = CStr(.[D8])
          If Len(r1) < Bnk Then
               i1 = String((Bnk - Len(r1)), "0") & r1
            Else
               i1 = r1
          End If
          If Len(r2) < Ky Then
               i2 = String((Ky - Len(r2)), "0") & r2
             Else
               i2 = r2
          End If
          If Len(r3) < Tol Then
               i3 = String((Tol - Len(r3)), "0") & r3
             Else
               i3 = r3
          End If
          If Len(r4) < Cus Then
               i4 = String((Cus - Len(r4)), "0") & r4
             Else
               i4 = r4
          End If
          X = "*" & String(Sr, "0") & i1 & i2 & i3 & i4 & r5 & r6 & String(14, " ") & "0"
'=======================================================================================
For Rw = 13 To .[A12].End(xlDown).Row
     If Not .Cells(Rw, 1) = Empty Then
'=======================================================================================
        Ibn1 = IIf(InStr(1, CStr(.Cells(Rw, 6)), ".") <> 0, Val(.Cells(Rw, 6) * 100), CStr(.Cells(Rw, 6)))
        n1 = CStr(.Cells(Rw, 4)): n2 = CStr(.Cells(Rw, 5)): n3 = Val(Ibn1)
        n4 = CStr(UCase(.Cells(Rw, 2))): n5 = CStr(UCase(.Cells(Rw, 3)))
        If Len(n1) < Bnk Then
                t1 = String((Bnk - Len(n1)), "0") & n1
           Else
                t1 = n1
        End If
        If Len(n2) < Ky Then
                t2 = String((Ky - Len(n2)), "0") & n2
           Else
                t2 = n2
        End If
        If (Len(n3) < Tol) Then
                t3 = String((Tol - Len(n3)), "0") & n3
           Else
                t3 = n3
        End If
        If (Len(n4 & " ") + Len(n5)) < Nm Then
                t4 = n4 & " " & n5 & String((Nm - (Len(n4 & " ") + Len(n5))), " ")
           Else
                t4 = n4 & " " & n5
        End If
        XX = XX & "*" & String(Sr, "0") & t1 & t2 & t3 & t4 & "1" & vbNewLine
'=======================================================================================
     End If
Next Rw
End With
'---------------------------
Xl_Ali = X & vbNewLine & XX & Chr(26)
'------------------------------------------------------------------------------
Bm = Split(Xl_Ali, vbNewLine): Sh2.Range("A1").Resize(UBound(Bm)) = Application.Transpose(Bm) _
 : Sh2.Range("A1").Offset(UBound(Bm) - 1) = Chr(26)
'---------------------------
Fil_Nm = FreeFile
'------------------------------------------------------------------------------
Pth = ThisWorkbook.Path & "\" & "Disq" & " " & r5 & r6 & ".txt"
'------------------------------------------------------------------------------
Open Pth For Output As #Fil_Nm
'---------------------------
Print #Fil_Nm, Xl_Ali
'---------------------------
Close #Fil_Nm
'---------------------------
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub

ع_ حسام · نوفمبر 25, 2015

شكر ا لك (......1 ) شكر هذه المرة عدد الأصفار من اليمين n مرة حيث N>>>>>>

حتى وقبل وبعد التجريبه على الملف الأصلي

**الـعيدروس** · نوفمبر 25, 2015

هل يعني زبط معاك ام هناك لخبطه ؟

تسجيل الدخول

المساعد في كود

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information