الترحيل من ورقة قيد يومية الى اليومية التحليلية

[sami salem]

الأخوة الأعزاء بالمنتدي العزيز

بارك الله لكم فيما تبذلونه من جهد لتوفير المعلومة التي تساعد الكثير منا فى العمل (( وكل عام وأنتم بخير وتقبل الله صيامنا جميعاً).

أرجو من لدية القدرة على عمل كود يقوم بترحيل قيد اليومية الى ورقة اليومية التحليلية كل حساب فى العمود الخاص به وكل قيد في صف منفرد مع عدم مسح البيانات من ورقة قيد اليومية (( حسب الملف المرفق )) ........ ولكم جزيل الشكر .

______.rar

[عبدالله باقشير]

السلام عليكم

تفضل المرفق

hasabat.rar

[sami salem]

الأخ / خبور خير

بعد السلام عليكم ورحمة الله وبركاته ،،،،

بارك الله فيك وزادك الله خيراً وأنعمك بنعيم الجنة , شكراً على المرفق (( ولكن )) أرجو أن يكون كود ترحيل قيد اليومية الى ورقة اليومية التحليلية في صف واحد وليس عدد صفوف وفى المرفق مثال للطلب ولك جزيل الشكر

hasabat.rar

[عبدالله باقشير]

السلام عليكم

استخدم الكود التالي :

Sub ترحيل()
Dim MyRang As Range
Dim LastRow As Integer, M As Integer, R As Integer, C As Integer
M = Application.CountA([B11:B31]) + 10
With ورقة11
    If .Cells(47, 3).End(xlUp).Row < 6 Then LastRow = 6 Else LastRow = .Cells(47, 3).End(xlUp).Row + 1
        Set MyRang = Range("B2,B3,A11,B4,B6,D4,B5")
    For R = 11 To M
        For C = 1 To 7
            .Cells(LastRow, C + 2) = MyRang.Areas(C)
        Next C
        If Application.CountA([D11:D31]) = 1 Then .Cells(LastRow, 10) = [B11] Else .Cells(LastRow, 10) = "مذكورين"
        If Application.CountA([E11:E31]) = 1 Then .Cells(LastRow, 11) = [B11] Else .Cells(LastRow, 11) = "مذكورين"
        .Cells(LastRow, Cells(R, 8).Value).Resize(1, 2).Value = Cells(R, 4).Resize(1, 2).Value
        .Cells(LastRow, 20) = Cells(R, 3).Value
    Next R
End With
'امسح الخلايا المنقولة اذا اردت ذلك
'Range("A11:E31").ClearContents
End Sub

[sami salem]

الأخ / خبور خير

بعد السلام عليكم ورحمة الله وبركاته ،،،،

بارك الله فيك وزادك الله بنعمة العلم والايمان وانشاء الله في ميزان حسناتك ولك جزيل الشكر

عندي استفسار هل يمكنني تعديل واضافة حسابات فى الدليل وفى صفحة اليومية التحليلية دون التأثير على الكود .

[عبدالله باقشير]

اذا غيرت المدى للصفوف في اليومية التحليلية يجب تغييرها في الكود

آخر صف حاليا 47

وبالنسبة للدليل اي حساب يجب ان يكتب رقم العمود لموقعه في اليومية التحليلية

قم بالتجربة واخبرنا ما الحاصل ؟؟

تم تعديل سبتمبر 24, 2008 بواسطه خبور خير

[sami salem]

الأخ / خبور

بعد السلام عليكم ورحمة الله وبركاته ،،،

لقد قمت بعمل بعض القيود وكانت النتيجة ممتازة ولكن فى قيد تحويل من حساب مصرف الى آخر قام بترحيل الدائن فقط كما فى المثال المرفق . ولك جزيل الشكر .

hasabat2.rar

[رفيق محمد]

السلام عليكم

اعذروني للمقاطعة

وكل عام وانتم بخير

ولكن الملف ده يهمني جداً واتمنى على اخي عبدالله يتم هذا العمل الرائع كما تعودنا من اعماله القيمة

وارجو توضيح خطوات تعديل واضافة حساب جديد وتاثير ذلك على الاسماء والنطاقات

جزاكم الله خيرا وبارك الله فيكم

[عبدالله باقشير]

تم تعديل الملف وقمت باضافة شرح في الكود

من اجل استخدام الكود للآخرين

Sub Kh_Start()
On Error Resume Next
Dim MyRang As Range
Dim LastRow As Integer, M As Integer, R As Integer, C As Integer
'===========================================
'عدد صفوف القيد المرحل زايداً فارق الصفوف في الورقةوهي 10 صفوف
M = Application.CountA([B11:B31]) + 10
'===========================================
'تجميع الخلايا الغير منتظمة في نساق واحد
Set MyRang = Range("B2,B3,A11,B4,B6,D4,B5")
'===========================================
'اذا كان القيد غير متوازن لا يتم الترحيل
If [D33] <> [E33] Then MsgBox "القيد غير متوازن", 524288, "تنبيه": GoTo 1
'===========================================
'تاكيد الاستمرار في الترحيل
If MsgBox("هل تريد الاستمرار في ترحيل القيد رقم : " & [B2], 4 + 32 + 524288 + 1048576, "تأكيد الترحيل") = 7 Then GoTo 1
'===========================================
With ورقة11
  '===========================================
  'اذا كانت آخر خلية في العمود الثالث في اليومية التحليلية
  'اصغر من 6 يبدا من الصف رقم 6 والا يعتمد آخر صف بزيادة صف واحد
    If .Cells(47, 3).End(xlUp).Row < 6 Then LastRow = 6 _
    Else LastRow = .Cells(47, 3).End(xlUp).Row + 1
  '===========================================
    Application.ScreenUpdating = False
    For R = 11 To M
        For C = 1 To 7
            .Cells(LastRow, C + 2) = MyRang.Areas(C)
        Next C
        If Application.CountA([D11:D31]) = 1 And Cells(R, 2) <> "" Then .Cells(LastRow, 10) = Cells(R, 2) _
        Else .Cells(LastRow, 10) = "مذكورين"
        If Application.CountA([E11:E31]) = 1 And Cells(R, 2) <> "" Then .Cells(LastRow, 11) = Cells(R, 2) _
        Else .Cells(LastRow, 11) = "مذكورين"
        If Cells(R, 3) <> "" Then .Cells(LastRow, 20) = Cells(R, 3).Value
        If Cells(R, 4) <> "" Then .Cells(LastRow, Cells(R, 8).Value).Value = Cells(R, 4).Value
        If Cells(R, 5) <> "" Then .Cells(LastRow, Cells(R, 8).Value + 1).Value = Cells(R, 5).Value
    Next R
End With
Application.ScreenUpdating = True
MsgBox "تم الترحيل بنجاح", 524288, "الحمد لله"
'===========================================
'امسح الخلايا المنقولة اذا اردت ذلك
'Range("B2:B6,D4").ClearContents
'Range("A11:E31").ClearContents
'===========================================
On Error GoTo 0
1 End Sub

hasabat2.rar

[sami salem]

الأخ / خبور

بعد السلام عليكم ورحمة الله وبركاته ،،،

سلمت يمينك وبارك الله لك فيما رزقت ويرزقك المزيد ............. شكراً جزيلاً ...

[عبدالله باقشير]

تصحيح للكود بشكل ادق :

Sub Kh_Start()
On Error Resume Next
Dim MyRang As Range
Dim LastRow As Integer, M As Integer, R As Integer, C As Integer
'===========================================
'عدد صفوف القيد المرحل زايداً فارق الصفوف في الورقةوهي 10 صفوف
M = Application.CountA([B11:B31]) + 10
'===========================================
'تجميع الخلايا الغير منتظمة في نساق واحد
Set MyRang = Range("B2,B3,A11,B4,B6,D4,B5")
'===========================================
'اذا كان القيد غير متوازن لا يتم الترحيل
If [D33] <> [E33] Then MsgBox "القيد غير متوازن", 524288, "تنبيه": GoTo 1
'===========================================
'تاكيد الاستمرار في الترحيل
If MsgBox("هل تريد الاستمرار في ترحيل القيد رقم : " & [B2], 4 + 32 + 524288 + 1048576, "تأكيد الترحيل") = 7 Then GoTo 1
'===========================================
With ورقة11
  '===========================================
  'اذا كانت آخر خلية في العمود الثالث في اليومية التحليلية
  'اصغر من 6 يبدا من الصف رقم 6 والا يعتمد آخر صف بزيادة صف واحد
    If .Cells(47, 3).End(xlUp).Row < 6 Then LastRow = 6 _
    Else LastRow = .Cells(47, 3).End(xlUp).Row + 1
  '===========================================
    Application.ScreenUpdating = False
    For R = 11 To M
        For C = 1 To 7
            .Cells(LastRow, C + 2) = MyRang.Areas(C)
        Next C
        If Application.CountA([D11:D31]) = 1 Then
            If Cells(R, 4) <> "" Then .Cells(LastRow, 10) = Cells(R, 2)
        Else
            .Cells(LastRow, 10) = "مذكورين"
        End If
        If Application.CountA([E11:E31]) = 1 Then
            If Cells(R, 5) <> "" Then .Cells(LastRow, 11) = Cells(R, 2)
        Else
            .Cells(LastRow, 11) = "مذكورين"
        End If
        If Cells(R, 3) <> "" Then .Cells(LastRow, 20) = Cells(R, 3).Value
        If Cells(R, 4) <> "" Then .Cells(LastRow, Cells(R, 8).Value).Value = Cells(R, 4).Value
        If Cells(R, 5) <> "" Then .Cells(LastRow, Cells(R, 8).Value + 1).Value = Cells(R, 5).Value
    Next R
End With
Application.ScreenUpdating = True
MsgBox "تم الترحيل بنجاح", 524288, "الحمد لله"
'===========================================
'امسح الخلايا المنقولة اذا اردت ذلك
'Range("B2:B6,D4").ClearContents
'Range("A11:E31").ClearContents
'===========================================
On Error GoTo 0
1 End Sub

[محمدي عبد السميع]

جزاك الله كل خير

[رفيق محمد]

دائما بالخير اخي خبور الخير

جزاك الله كل الخير

[يحيى حسين]

طريقة جميلة للشرح

جزاك الله كل خير اخي خبور

و جعلها الله في ميزان حسناتك

عيدكم مبارك

كل عام و انتم بخير

[tarek]

مشكور ياغالى

أعمال عظيمة

www.bentelshate.jeeran.com

[هشام شلبى]

الاخ طارق

اعجبنى جدا طريقة عمل موقعك

ولكن ارجو منك شرح كيفية ادراج الجدول المدرسى والقوائم المنسدلة داخل الموقع

وشكرا مقدما

[أبو صفا]

بارك الله فيكم جميعاً وجعل ذلك في موازين حسناتكم

[awadid]

تسلم ايديك انا فعلا استفد من الموضوع لالكن لى استفسار هل ممكن ان اجمع كل حسابات البنوك فى عمود واحد كما هو ظاهر فى الملف المرفق

[awadid]

السلام عليكم ورحمة الله وبركاتة

لم اجد كلمات حتى اوفيك حقق من الفائدة العائدة على كل المستفيدين من الموقع

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

[الجزيرة]

كم أنت رائع يا عبد الله