تعديل كود ترحيل

[Eid Mostafa]

الأخوة الأفاضل

الملف المرفق به كود ترحيل ( وهو لأحد عمالقة المنتدى وعذراً إن كنت نسيت إسمه ) يقوم بترحيل بيانات قيد اليومية إلى شيت اليومية الأمريكية ، وقد حاولت التعديل علية ليتوافق مع أسماء الحسابات التى أستخدمها ولكن لقلة خبرتى بالأكواد فلم أستطع ذلك !!!!

لذا أرجو من الأخوة الأعزاء تعديل الكود المرفق بحيث يقوم بترحيل بيانات قيد اليومية إلى شيت اليومية الأمريكية وفقاً لكل حساب على حدة.

ولكم جزيل الشكر.

عيد مصطفى

Statement to Send (CODES).rar

[طارق محمود]

السلام عليكم

أخي العزيز

أولا هذا الكود من أعمال العلامة الجليل / خبور خير ، سلمه الله من كل شر

<< عادة مايبدأ إسم أكواده بحرفي Kh - وقد وجدت إسم الكود

Sub Kh_Start()

>>

ثانيا الغرض من الكود لم يكن كما تريد ، فقد تم تصميمه لشيئ آخر

ثالثا ماتطلبه يحتاج بعض الوقت ، سأعمل عليه إن شاء الله

[طارق محمود]

السلام عليكم

تفضل أخي الملف وبه الكود المعدل

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 = [E1000].End(xlUp).Row

'===========================================

'اذا كان القيد غير متوازن لا يتم الترحيل

If [C45] <> [D45] Then MsgBox "القيد غير متوازن", 524288, "تنبيه": Exit Sub

'===========================================

With Sheet55

  '===========================================

  'اذا كانت آخر خلية في العمود الثالث في اليومية التحليلية

  'اصغر من 6 يبدا من الصف رقم 4 والا يعتمد آخر صف بزيادة صف واحد


    LastRow = .Cells(1000, 3).End(xlUp).Row + 1

    If LastRow < 4 Then LastRow = 4


  '===========================================

    'Application.ScreenUpdating = False

    .Cells(LastRow, 1) = [b2]

    .Cells(LastRow, 2) = [b3]


    For R = 7 To M

	    deb = Cells(R, 3): crd = Cells(R, 4): Acnt = Cells(R, 5).Value

	    If deb = "" And crd = "" Then GoTo 10


	    For t = 6 To 278 Step 2

		    x = .Cells(2, t)

		    If x = Acnt Then GoTo 20

	    Next t

	    MsgBox ("Not Exist Record")

	    Exit Sub


20	  'Remember t = Right Column No

	    .Cells(LastRow, t) = .Cells(LastRow, t) + deb

	    .Cells(LastRow, t + 1) = .Cells(LastRow, t + 1) + crd

10	 Next R

End With

Application.ScreenUpdating = True

MsgBox ("تم الترحيل بنجاح" & Chr(10) & "الحمد لله")

'===========================================

'لو أردت مسح الخلايا المنقولة ، فقط فعل السطر التالي بإزالة الأبوستروف من اوله

'Range("B2:B3,C7:E44").ClearContents

'===========================================

On Error GoTo 0

End Sub

Statement to Send (CODES)2.rar

[Eid Mostafa]

الأخ العزيز / طارق

لك منى كل التقدير على ردك السريع أولاً وعلى مجهودك الرائع ثانياً

وتحياتى للعلامة الجليل / خبور خير أيضاً على مجهوداتة الرائعة.

وأكرر إعتذارى مرة أخرى على نسيانى للإسم.

خالص تحياتى وتقديرى لكل القائمين على هذا المنتدى الرائع

وفقنا الله وإياكم لما فية الخير.

عيد مصطفى

[Eid Mostafa]

الأخ العزيز / طارق

لقد تبين لى من إستخدام الملف بعد تعديل الكود بواسطتكم أن القيد يرحل دائماً فى الصف الأول (C4) من شيت اليومية الأمريكية.

بمعنى أن القيد الأول تم ترحيلة إلى الصف الأول (C4) ، وعند عمل القيد التالى تم ترحيلة إلى نفس الصف الأول (Overwriting) بدلاً من القيد الأول.

أرجو التكرم بالإفادة.

كما أن لى طلب آخر لإدراجة بالتعديل ألا وهو (إدراج شرح القيد خلية E43 بالعمود C باليومية الأمريكية)

أرجو ألا أكون قد أثقلت عليك.

مرفق الملف

خالص تحياتى وتقديرى

عيد مصطفى

Statement to Send (CODES)2.rar

[Eid Mostafa]

الأخ العزيز / طارق

حتى لا أثقل عليك فدعك من تعديل الملف كما طلبت منك فى الرد السابق.

وأرجو منك الإهتمام بتعديل الطلب الوارد بمشاركتى الأخرى بعنوان (كود ترحيل) ، والتى أرفقت إليك بها الملف التالى Statement to Send_ALL2.rar.

مرفق الملف

ولك خالص تحياتى وتقديرى ،،،،،،

أخوك / عيد مصطفى

Statement to Send_ALL2.rar

[طارق محمود]

السلام عليكم

ليكن أخي الحبيب

ولذلك ، سأغلق هذا الموضوع

وليكن من الغد بدء العمل علي موضوعك الآخر فهو أشمل ويتضمن هذا الموضوع داخله