طارق محمود

السلام عليكم ياأخي الكريم إفرض كما تحب فنحن جميعا هنا عونا لبعضنا البعض بالنسبة لسؤالك ، ممكن طبعا كليك يمين داخل الجدول إختر Pivot Table Wizard ثم غير التنسيق كما تحب ضع الأعمدة مكان الصفوف أوالأصناف فوق الشهور .. أنظر المرفق يوسف أبو شناف3.rar

بالجداول المحورية أنظر المرفق يوسف أبو شناف2.rar

أخي انور في أول رد لاخينا العزيز بن علية قال لك إن كنت تريد إظهار ذلك علي الطباعة أم على الشاشة وقد وضح كلتا الحالتين وهذا جزء من رده وهذا الحل يعتمد علي توافر الخاصية في الطابعة أنظر الصورة

السلام عليكم أخي منسق أي أنك تريد 1. إذا لم يتحقق الشرط الأول ، فلا يتم الترحيل ابدا 2. إذا تحقق الشرطين الأول والثاني فيتم النسخ للبيانات ببساطة 3. إذا تحقق الشرط الأول ولم يتحقق الشرط الثاني فيتم النسخ للبيانات الجديدة فوق مثيلاتها في الورقة الثانية هل هذا ماتقصد؟؟

السلام عليكم أخي أنور ممكن تضع أي صورة وهمية في الجانب الفاضي وتجعلها = المدي المطلوب طباعته كنت تعرضت لمثل هذه المشكلة وحللتها كذلك أنظر المرفق اوقات الصلاة.rar

السلام عليكم أخي العزيز إذا لاحظت المعادلة في الخلية P7 ستجد أنه هكذا =IF(AND($N7<=P$4,$O7>=P$4,OR(WEEKDAY(P$4)=1,WEEKDAY(P$4)=2,WEEKDAY(P$4)=5)),P$4,"") وجزء منها هو OR(WEEKDAY(P$4)=1,WEEKDAY(P$4)=2,WEEKDAY(P$4)=5) وهذا بدوره يعتمد علي دالة أيام الأسبوع WEEKDAY وهي دالة تعبر عن يوم الأحد بالرقم 1 والإثنين بــ 2 وهكذا ولذلك فقد كانت الأرقام حسب طلبك في هذه الدالة هي: 1 ,2, 5 عالترتيب فهكذا تستطيع تغيير إلي الثلاثاء مثلا بوضع الرقم 3 وهكذا ثم تأخذ من الخلية P7 نخة بالعرض لباقي الخلايا

أخي العزيز أرجو إرسال الملف بآخر تعديلات مع إزالة العربي من الأكواد

السلام عليكم أخي طالب واضح أنك شحييييح في الشرح ولكن ارجو أن يكون المرفق هو ماتطلب أنتظر ردك بنعم أو بشرح أكثر تفضل المرفق Caleander2.rar

أخيرا يكون الكود إجمالا كالتالي Sub QID() Dim s_name(99), S_ACC(99), s_amount(99), S_explain(99) As Variant, xxx As String S_NAMESANAD = Range("E2").Value '______________________________________________ Qaid_No = WorksheetFunction.CountA("B5:B1000") '______________________________________________ Range("IV1").Value = Range("IV1").Value + 1 S_KIND = "QAID" S_SER = Range("E2").Value S_DATE = Range("B3").Value '______________________________________________ For I = 1 To Qaid_No s_name(I) = Range("B" & I + 4).Value S_ACC(I) = Range("IU" & I + 4).Value s_amount(I * 2 - 1) = Range("C" & I + 4).Value s_amount(I * 2) = Range("D" & I + 4).Value S_explain(I) = Range("E" & I + 4).Value Next I '______________________________________________ A = Workbooks.Count X = "Close" For I = 1 To A If Workbooks(I).Name = "2.xls" Then X = "OPEN" Next I If X = "Close" Then xxx = ActiveWorkbook.Path & "\" & "2.xls": Workbooks.Open xxx Windows("2.xls").Activate '______________________________________________ 'ACC(1 To Qaid_No) For qq = 1 To Qaid_No X = Worksheets.Count For I = 1 To X If Worksheets(I).Name = s_name(qq) Then GoSub 3333 Next I Sheets("sample").Select Sheets("sample").Copy Before:=Sheets(1) ActiveSheet.Name = s_name(qq) Range("C1").Value = S_ACC(qq) Range("F3").Value = s_name(qq) Next qq '______________________________________________ 3333 Worksheets(s_name(qq)).Select Range("a1000").Select Selection.End(xlUp).Select If ActiveCell.Row = 5 Then ser = 1 Else ser = ActiveCell.Value + 1 ActiveCell.Offset(1, 0).Select ActiveCell.Value = ser ActiveCell.Offset(0, 1).Value = s_amount(qq * 2 - 1) ActiveCell.Offset(0, 2).Value = s_amount(qq * 2) ActiveCell.Offset(0, 5).Value = S_explain(qq) ActiveCell.Offset(0, 6).Value = S_DATE ActiveCell.Offset(0, 7).Value = S_KIND ActiveCell.Offset(0, 8).Value = S_SER If WorksheetFunction.MOD(qq, 2) = 1 Then qid_f = 1 Else qid_f = -1 ActiveCell.Offset(0, 9).Value = s_name(qq + qid_f) Return '______________________________________________ Windows("1.xls").Activate Range("A1").Select End Sub

ثانيا إلغي كل الأكواد المتكررة من 1 إلي 20 (إلغيها كلها) ثم إستبدلها بالكود التالي 'ACC(1 To Qaid_No) For qq = 1 To Qaid_No X = Worksheets.Count For I = 1 To X If Worksheets(I).Name = s_name(qq) Then GoSub 3333 Next I Sheets("sample").Select Sheets("sample").Copy Before:=Sheets(1) ActiveSheet.Name = s_name(qq) Range("C1").Value = S_ACC(qq) Range("F3").Value = s_name(qq) Next qq 3333 Worksheets(s_name(qq)).Select Range("a1000").Select Selection.End(xlUp).Select If ActiveCell.Row = 5 Then ser = 1 Else ser = ActiveCell.Value + 1 ActiveCell.Offset(1, 0).Select ActiveCell.Value = ser ActiveCell.Offset(0, 1).Value = s_amount(qq * 2 - 1) ActiveCell.Offset(0, 2).Value = s_amount(qq * 2) ActiveCell.Offset(0, 5).Value = S_explain(qq) ActiveCell.Offset(0, 6).Value = S_DATE ActiveCell.Offset(0, 7).Value = S_KIND ActiveCell.Offset(0, 8).Value = S_SER If WorksheetFunction.MOD(qq, 2) = 1 Then qid_f = 1 Else qid_f = -1 ActiveCell.Offset(0, 9).Value = s_name(qq + qid_f) Return والله الموفق

السلام عليكم أولا ممكن تغيير رقم الــ 20 الموجود في أول كل Loop مثل For I = 1 To 20 بأن تسبق ذلك بخطوة إستكشاف لعدد القيود الجاهزة للترحيل بملاحظة أن القيد لابد أن يكون فيه إسم ما في العمود B بداية من الخلية B5 ممكن مثلا تضيف الأمر التالي لتسجيل عدد القيود الجاهزة Qaid_No = WorksheetFunction.CountA("B5:B1000") ثم تستبدل كل رقم 20 موجود في أول كل Loop إلي Qaid_No كالتالي For I = 1 To Qaid_No ينتج عن هذا أن يعد أولا القيود الموجودة فعلا فيتغير برنامج القراءة في أول الكود إلي قراءة هذا العدد فقط وليس الــ 20

السلام عليكم لو لاحظت ماذكرته ستجد أن نفس المعادلة متكررة وفقط يزيد الرقم بمقدار واحد كل سطر وكذلك العلاقة بين الرقم في يمين ويسار المعادلة أنه بفارق 4 دائما وهكذا مثلا S_ACC1 = Range("IU5").Value أو S_explain1 = Range("E5").Value وعلي ذلك تكون الأكواد كالتالي For i = 1 To 20 S_ACC(i) = Range("IU" & i + 4).Value Next i For i = 1 To 20 S_explain(i) = Range("E" & i + 4).Value Next i

بعض النصائح بخصوص فتح الملف وإغلاقه والكتابة فيه 1. أولا تراجع إذا كان الملف مفتوح وإلا يفتحه 2. تضع إسم الملف مع مساره في متغير يمكنك من فهمه مستقبلا مثلا يمكنك إضافة متغير PACK_LIST هكذا PACK_LIST = "D:\xxxx\yyyy\DK\ACCOUNTS\ARCHIVES\INVOICE\PACKINGLIST.XLS" ثم تطلب فتحه هكذا Workbooks.Open PACK_LIST أو تنشطه لإستقبال الترحيل أو أخذ البيانات هكذا Windows(PACK_LIST).Activate

مبدئيا لابد ان تكتب المسار كاملا في كل ماذكرت ، لابد أن تذكر أولا ماقبل الــ DK وتصل بها إلي أحد أجزاء الهارد ديسك C:\ أو D:\ مثلا code]<br>C:\xxxx\yyyy\DK\ACCOUNTS\... أو D:\xxxx\yyyy\DK\ACCOUNTS\...

أولا كما إتفقنا هذا السطر في أول الكود Dim s_amount(99) As Variant ولابد أن يكون إدخال البيانات لهذه المتغيرات بصورة المصفوفة أي s_amount (1) بدلا من s_amount1 ثم هذ الأسطر For i = 1 To 40 ActiveCell.Offset(0, i).Value = s_amount(i) Next i For i = 1 To 40 ActiveCell.Offset(0, i).Value = s_amount(i) Next i

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

لم أفهم سؤالك هذا أرجو إعادة صياغته

الرابعة: الكود يرحل ولو من غير قيمة في المدين أو الدائن... هل من حل؟ إن شاء الله يوجد حل: في أول كود القيد الذي أرسلته أنت Sub QID() Dim xxx As String S_NAME1 = Range("C6").Value S_NAME2 = Range("C7").Value s_Acc1 = Range("B6").Value s_Acc2 = Range("B7").Value s_explain = Range("f6").Value '=== === S_explain2 = Range("F7").Value '=== === s_kind = Range("E2").Value '=== ¡ === S_AMOUNT1 = Range("D6").Value '=== ===== S_AMOUNT2 = Range("E6").Value '=== ===== فما عليك إلا أن تضيف الشرطين التاليين مباشرة بعد هذه الأسطر If S_AMOUNT1 = 0 And S_AMOUNT2 = 0 Then Exit Sub ' Case 1 both = zero If S_AMOUNT1 > 0 And S_AMOUNT2 > 0 Then Exit Sub ' Case 2 both > zero أول شرط إذا كانا كلا من الدائن والمدين أصفارا يعني بلا قيمة ، فسيخرج من البرنامج ولن يرحل ثاني شرط إذا كانا كلا من الدائن والمدين أكبر من صفرا يعني أنك أخطأت ووضعت قيمة لكلا منهما في قيد واحد ، فسيخرج أيضا من البرنامج ولن يرحل

لا أفهم كيف يجبرك؟ أعني يبدو أنك أضفت للكود شرطا لاأعلمه لابد من إرسال الكود مع إستبدال الحروف العربية بأي إختصارات لها بالإنجليزية أرجو أن أكون فهمت المشكلة أنت قد وضعت له للقراءة جميع خلايا الورقة التي من الممكن إستخدامها بعدما ترسل الكود مع إستبدال الحروف العربية بأي إختصارات لها بالإنجليزية ، سأعدله بإذن الله ليقبل الترحيل بغض النظر عن ذلك

والآن مشكلة الدليل (أو المجلد) الذي تخزن فيه النسخة للسهولة في هذه المرحلة ، إجعل دليلا واحدا به كافة الأعمال فقط غير من أسماء الملفات وهذا الدليل هو ActiveWorkbook.Path بمعني أنك إذا كنت متأكد من 1. وجود ملفا آخر في نفس الدليل إسمه Accounts.xls مثلا وتريد وضع هذه البيانات فيه 2. أن هذا الملف مغلق عند هذه الخطوة فإنك تكتب كما بالكود السابق هكذا xxx = ActiveWorkbook.Path & "\" & "Accounts.xls" Workbooks.Open xxx لو أي من الشرطين غير متوافر سيعطي خطأ

السلام عليكم سأرد علي ماتيسر وليس بالترتيب يبدو أنك لم تنتبه لتسلسل الأوامر عند إنشاء ورقة جديدة كنسخة من "SAMPLE" ثم إعادة تسميتها بإسم كذا فقبل لك لابد أن تتأكد انه لايوجد ورقة بهذا الإسم وإلا لاداعي لعمل نسخة أخري ، فقط فليذهب للخطوة التالية أعلم ان الموضوع ليس سهلا ولكنك ستخرج من هذه التجربة علي دراية بما يصلح لك من الأكواد أرفقت لك صورة من جزء من شرح الأمس بخصوص هذه الجزئيةوبه رسالة الخطأ التي أرفقها أنت

أخي الحبيب كلنا كنا أسوأ كثيرا من بدايتك هذه علي سبيل المثال هذا الجزء من الكود اللي أرسلته إنت وأسفله كود آخر مكافيء له تماما ولكن أقصر منه S_AMOUNT2 = Range("D5").Value S_AMOUNT3 = Range("C6").Value S_AMOUNT4 = Range("D6").Value S_AMOUNT5 = Range("C7").Value S_AMOUNT6 = Range("D7").Value S_AMOUNT7 = Range("C8").Value S_AMOUNT8 = Range("D8").Value S_AMOUNT9 = Range("C9").Value S_AMOUNT10 = Range("D9").Value S_AMOUNT11 = Range("C10").Value S_AMOUNT12 = Range("D10").Value S_AMOUNT13 = Range("C11").Value S_AMOUNT14 = Range("D11").Value S_AMOUNT15 = Range("C12").Value S_AMOUNT16 = Range("D12").Value S_AMOUNT17 = Range("C13").Value S_AMOUNT18 = Range("D13").Value S_AMOUNT19 = Range("C14").Value S_AMOUNT20 = Range("D14").Value S_AMOUNT21 = Range("C15").Value S_AMOUNT22 = Range("D15").Value S_AMOUNT23 = Range("C16").Value S_AMOUNT24 = Range("D16").Value S_AMOUNT25 = Range("C17").Value S_AMOUNT26 = Range("D17").Value S_AMOUNT27 = Range("C18").Value S_AMOUNT28 = Range("D18").Value S_AMOUNT29 = Range("C19").Value S_AMOUNT30 = Range("D19").Value S_AMOUNT31 = Range("C20").Value S_AMOUNT32 = Range("D20").Value S_AMOUNT33 = Range("C21").Value S_AMOUNT34 = Range("D21").Value S_AMOUNT35 = Range("C22").Value S_AMOUNT36 = Range("D22").Value S_AMOUNT37 = Range("C23").Value S_AMOUNT38 = Range("D23").Value S_AMOUNT39 = Range("C24").Value S_AMOUNT40 = Range("D24").Value المكافيء له أولا هذا السطر في أول الكود Dim s_amount(99) As Variant ثم هذ الأسطر بدلا من أسطرك For i = 1 To 20 s_amount(i * 2 - 1) = Range("C" & i + 4).Value s_amount(i * 2) = Range("D" & i + 4).Value Next i أعني أنه يمكن الحل دائما بطرق كثيرة وسوف تتعجب من قصرها والله الموفق

السلام عليكم أخي العزيز أنظر للصورة التي أراها بالجهاز سأضطر لإرجاء الموضوع للغد عموما كنت قد جهزت لك شرح في كود القيد الأخير سأرفقه أيضا تفكر به حتي الغد برجاء قراءة آخر سطرين جيدا يمكن يفتح الله عليك بحل شرح كود القيد.rar

السلام عليكم ياأخي بالله لاتستحي بل إشرح اكثر فأنا لست محاسبا لذلك لاأفهم كثيرا من الطلبات

السلام عليكم تفضل أخي المرفق وهذا هو الكود الخاص بذلك Sub shift() Dim a(9) As String Worksheets(1).Activate Range("a41:n43").Select For i = 41 To 43 a(i - 40) = Range("a" & i).Value If a(i - 40) = "" Then MsgBox ("First Cell Empty in Row #" & i): Exit Sub Next i Worksheets(2).Activate Range("a1000").Select Selection.End(xlUp).Select last_r = ActiveCell.Row For i = 1 To 3 For j = 3 To last_r If Range("a" & j) = a(i) Then MsgBox ("Repeated Record in Row #" & j): Exit Sub Next j Next i End Sub سيعطيك رسالة في حالة خلو أي من الخلايا الأولي في العمود الأول من الصفوف الأخيرة وسيعطيك رسالة أخري في حالة وجود أي من الأرقام الثلاثة في الخلية الأولى في العمود الأول من الورقة الثانية ترحيل بشرط.rar