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

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

السلام عليكم بعد اضافة الازرار وغيره بمثل الطريقة التي اوردها اخي بن عليه هذه طريقة لربطها بالاكواد بمثل ما اورد الاخ حمادة باشا المرفق 2010 MultiPage15.rar

السلام عليكم تم التعديل على بعض الاكواد الموجودة ومنها قائمة الاستعلام عن رقم القيد المرفق 2010 بالفورم_سند قيد مزدوج+.rar

السلام عليكم الاخ الفاضل / حمادة باشا جزاك الله خيرا معلومات قيمة تقبلوا تحياتي وشكري

السلام عليكم استخدم الكود التالي Sub Macro1() Dim LR As Long LR = Cells(Rows.Count, "A").End(xlUp).Row If LR = 1 Then Exit Sub Application.ScreenUpdating = False Range("A2:C" & LR).Copy With Sheets("ورقة8") LR = .Cells(Rows.Count, "A").End(xlUp).Row + 1 .Range("A" & LR).PasteSpecial xlPasteValues End With Application.CutCopyMode = False Range("A2:C43").ClearContents Application.ScreenUpdating = True End Sub تحياتي

تم فصل الطلب في موضوع مستقل

السلام عليكم شاهد المرفق 2010 africa1.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:B39]) + 10 '=========================================== 'تجميع الخلايا الغير منتظمة في نساق واحد Set MyRang = Range("B2,B3,A11,B4,B5,B6,B7") '=========================================== 'اذا كان القيد غير متوازن لا يتم الترحيل If Range("D41").Value = False Then MsgBox "القيد غير متوازن", 524288, "تنبيه": GoTo 1 '=========================================== 'تاكيد الاستمرار في الترحيل If MsgBox("هل تريد الاستمرار في ترحيل القيد رقم : " & [B2], 4 + 32 + 524288 + 1048576, "تأكيد الترحيل") = 7 Then GoTo 1 '=========================================== With ورقة11 '=========================================== 'اذا كانت آخر خلية في العمود الثالث في اليومية التحليلية 'اصغر من 6 يبدا من الصف رقم 6 والا يعتمد آخر صف بزيادة صف واحد If .Cells(5997, 3).End(xlUp).Row < 6 Then LastRow = 6 _ Else LastRow = .Cells(5997, 3).End(xlUp).Row + 1 '=========================================== Application.ScreenUpdating = False For C = 1 To 7 .Cells(LastRow, C + 2) = MyRang.Areas(C) Next For R = 11 To M If Len(.Cells(LastRow, 10)) Then GoTo 10 If Application.CountA([D11:D39]) > 1 Then .Cells(LastRow, 10) = "مذكورين": GoTo 10 If Val(Cells(R, 4)) Then .Cells(LastRow, 10) = Cells(R, 2) 10 If Len(.Cells(LastRow, 11)) Then GoTo 20 If Application.CountA([E11:E39]) > 1 Then .Cells(LastRow, 11) = "مذكورين": GoTo 20 If Val(Cells(R, 5)) Then .Cells(LastRow, 11) = Cells(R, 2) 20 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,B7").ClearContents Range("A11:E39").ClearContents '=========================================== On Error GoTo 0 1 End Sub تحياتي

السلام عليكم تم تعديل الكود التالي 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:B39]) + 10 '=========================================== 'تجميع الخلايا الغير منتظمة في نساق واحد Set MyRang = Range("B2,B3,A11,B4,B5,B6,B7") '=========================================== 'اذا كان القيد غير متوازن لا يتم الترحيل If Range("D41").Value = False Then MsgBox "القيد غير متوازن", 524288, "تنبيه": GoTo 1 '=========================================== 'تاكيد الاستمرار في الترحيل If MsgBox("هل تريد الاستمرار في ترحيل القيد رقم : " & [B2], 4 + 32 + 524288 + 1048576, "تأكيد الترحيل") = 7 Then GoTo 1 '=========================================== With ورقة11 '=========================================== 'اذا كانت آخر خلية في العمود الثالث في اليومية التحليلية 'اصغر من 6 يبدا من الصف رقم 6 والا يعتمد آخر صف بزيادة صف واحد If .Cells(5997, 3).End(xlUp).Row < 6 Then LastRow = 6 _ Else LastRow = .Cells(5997, 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 Len(.Cells(LastRow, 10)) Then GoTo 10 If Application.CountA([D11:D39]) > 1 Then .Cells(LastRow, 10) = "مذكورين": GoTo 10 If Val(Cells(R, 4)) Then .Cells(LastRow, 10) = Cells(R, 2) 10 If Len(.Cells(LastRow, 11)) Then GoTo 20 If Application.CountA([E11:E39]) > 1 Then .Cells(LastRow, 11) = "مذكورين": GoTo 20 If Val(Cells(R, 5)) Then .Cells(LastRow, 11) = Cells(R, 2) 20 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,B7").ClearContents Range("A11:E39").ClearContents '=========================================== On Error GoTo 0 1 End Sub جرب واشعرنا بالنتيجة شاهد الملف 2003 اليومية الأخيرة.rar

السلام عليكم شاهد هذا المرفق 2003 يعمل سيناريو تجميع عدة قيم للحصول على قيمة معينة سيناريو جدول1.rar

السلام عليكم الشكر واصل للفاضلة حاملة المسك حفظها الله الاخ الفاضل فضل1_____حفظكم الله جزاكم الله خيرا تحتاج الى وضع النطاق بين قوسين ضع هذه المعادلة في الخلية IT3 واسحبها على باقي العمود =kh_test((D3:AG3;AI3:BM3;BO3:CR3;CT3:DX3;DZ3:FD3;FF3:GH3;GJ3:HN3;HP3:IS3)) تحياتي

السلام عليكم تم عمل معادلة بالكود Function kh_test(Rnge As Range) As String Dim Cel As Range kh_test = "غير متتالى" For Each Cel In Rnge If CStr(Cel) = "غ" Then i = i + 1 If i = 15 Then kh_test = "متتالى": Exit For If CStr(Cel) <> "غ" Then i = 0 Next End Function تضع المعادلة في الخلية BM4 وتسحبها على باقي العمود =kh_test((C3:AF3;AH3:BK3)) المرفق 2003 الغياب.rar

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

السلام عليكم لقد حذفت انت هذا الكود قم بارجاعه هو كود تابع لكود الميزان Sub kh_Application(mbol As Boolean) With Application .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol .EnableEvents = mbol End With End Sub تحياتي

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم هل هذا صحيح او العكس ؟؟ شاهد المرفق وتاكد من صحة الميزان المرفق 2010 نظام محاسبي.rar

السلام عليكم هذا بين تاريخين ويمكنك استخدامة للفترات بوضع اول تاريخ للشهر واخر تاريخ للشهر المرفق 2010 نظام محاسبي.rar

السلام عليكم ميزان المراجعة الذي تريده حسب عمود الشهر او التاريخ ؟

الحمدلله رب العالمين جزاكم الله خيرا

السلام عليكم شاهد المرفق 2010 Copy of دليل طارق.rar

السلام عليكم شاهد المرفق 2003 دليل هاتف 11طارق زكريا.rar

السلام عليكم عملنا فورم تدخل الرقم في التاكست واضغط الزر لتنفيذ الكود Private Sub CommandButton1_Click() Dim sp Dim iNum As String Dim i As Integer For Each sp In Split(Me.TextBox1, ".") i = i + 1 iNum = iNum & Format(sp, IIf(i = 3, "0000", "000")) Next Me.Label1 = iNum End Sub تفضل المرفق 2003 NUM.rar

السلام عليكم ضع هذ الكود في حدث ورقة1 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row > 14 Then Range("H7").Value = Cells(Target.Row, "R").Value End If End Sub تحياتي

السلام عليكم ضع هذا الكود في حدث ورقة1 Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("B1:B5")) Is Nothing Then With Range("A1:B5") .Sort .Columns(2), xlDescending End With End If End Sub المرفق 2010 222222.rar تحياتي

جزاكم الله خيرا وبارك فيكم وكل عام وانتم بخير تقبلوا تحياتي وشكري