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

السلام عليكم احسنت اخي محمود ------------حفظك الله استمر الله يرعاك تقبل تحياتي وشكري

اخي الفاضل حماده --------حفظك الله اكرمك الله احبك الله مثل ما احببتني جزاك الله خرا تقبل تحياتي وشكري

السلام عليكم هذا التعديل افضل Sub test2() Dim m As Integer, c As Integer Dim cRng As Range, rngLoopRange As Range ''''''''''''''''''''' With Sheets("MAIN") Set cRng = .Range("B5:B" & .Range("B" & Rows.Count).End(xlUp).Row) End With ''''''''''''''''''''' Application.ScreenUpdating = False For Each rngLoopRange In cRng m = Month(rngLoopRange) c = ((m - 1) * 5) + 2 With Sheets("خلاصة").Cells(Rows.Count, c).End(xlUp).Offset(1, 0) rngLoopRange.Resize(, 4).Copy .Cells End With Next rngLoopRange Application.ScreenUpdating = True Set cRng = Nothing End Sub

السلام عليكم على السريع كود المسح الترحيل لورقة الخلاصة Sub delete2() Sheets("خلاصة").Range("B4:BH1000").ClearContents End Sub Sub test2() Dim m As Integer, c As Integer, Last As Integer Dim cRng As Range, rngLoopRange As Range ''''''''''''''''''''' With Sheets("MAIN") Set cRng = .Range("B5:B" & .Range("B" & Rows.Count).End(xlUp).Row) End With ''''''''''''''''''''' Application.ScreenUpdating = False For Each rngLoopRange In cRng m = Month(rngLoopRange) c = (m - 1) * 4 c = c + m + 1 With Sheets("خلاصة").Cells(Rows.Count, c).End(xlUp).Offset(1, 0) rngLoopRange.Resize(, 4).Copy .Cells End With Next rngLoopRange Application.ScreenUpdating = True Set cRng = Nothing End Sub للعلم تم تعديل باقي الاكواد في المرفق المرفق 2003 monthly report.rar

السلام عليكم اخى الحبيب / محمود ---------------حفظه الله رائع جدا جزاك الله خيرا وبارك فيك تقبل تحياتي وشكري

السلام عليكم احسنت اخي ياسر حفظك الله جزاك ربي خيرا وبارك فيك اخي الفاضل dah_med البطاقة رائعة جدا سلمت يداك تقبلوا تحياتي وشكري

كل تاخير وفيه خير استخدمت كود آخر اسرع من السابق الكود: Option Explicit Private Const ContColmn As Integer = 11 '====================================================== '====================================================== Sub kh_m2Report() Dim obj As Object Dim x(), AryList() Dim iKey Dim iTm As Range, Rng As Range Dim LastRow As Long, iCont As Long Dim i As Long, ii As Long, iii As Long Dim c As Integer, m As Integer Dim Md As Double, Dn As Double '============================================ Set obj = CreateObject("Scripting.Dictionary") '============================================ With Cells.Worksheet LastRow = .Cells(Rows.Count, "B").End(xlUp).Row With .Range("B5") .Activate .Resize(1, ContColmn).ClearContents .Offset(1, 0).Resize(LastRow, ContColmn).Clear End With End With '============================================ With Sheets("daily") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Set Rng = .Range("A4:A" & LastRow) End With '============================================ On Error GoTo kh_ex kh_Application False '============================================ For Each iTm In Rng iKey = Val(iTm.Cells(1, 5)) Md = Val(iTm.Cells(1, 7)) Dn = Val(iTm.Cells(1, 8)) ''''''''''''''''''' If obj.Exists(iKey) Then iii = obj(iKey) '''''''''''''''''' x(2, iii) = Val(x(2, iii)) + Md x(3, iii) = Val(x(3, iii)) + Dn Else ii = ii + 1 ReDim Preserve x(1 To 3, 1 To ii) obj.Add iKey, ii '''''''''''''''''' x(1, ii) = iKey x(2, ii) = Md x(3, ii) = Dn End If Next '============================================ iCont = obj.Count If iCont Then Set Rng = Sheets("code").Range("A2:A350") ReDim AryList(1 To iCont, 1 To ContColmn) For i = 1 To iCont '''''''''''''''''' On Error Resume Next iKey = x(1, i) m = WorksheetFunction.Match(iKey, Rng, 0) If Err Then m = 0: Err.Clear '''''''''''''''''' Md = x(2, i): Dn = x(3, i) AryList(i, 1) = Md AryList(i, 2) = iKey '''''''''''''''''' If m Then For c = 3 To 9 AryList(i, c) = Rng.Cells(m, c - 1) Next End If '''''''''''''''''' AryList(i, 10) = Dn AryList(i, 11) = Md - Dn '''''''''''''''''' Next '============================================ With Range("B5").Resize(iCont, ContColmn) If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats .Value = AryList .Sort .Columns(2), xlAscending End With ''''''''''''''''''''''''' End If '============================================ kh_ex: kh_Application True '''''''''''''''''' If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else MsgBox "تم تحديث الميزان بنجاح ", vbMsgBoxRight, "الحمدلله" End If '''''''''''''''''' Set obj = Nothing Set Rng = Nothing Erase x, AryList '''''''''''''''''' End Sub المرفق 2003-2007 ميزان مراجعة للاخ ريد2.rar

السلام عليكم الاخ الفاضل بارك الله فيك لقد تم تعديل عنوان الموضوع نظرا لجهدك في شرح الطلب الرجاء قراءه قواعد المشاركه في المنتدى و الالتزام بها http://www.officena.net/Tips/Questions.htm

السلام عليكم هذا المرفق اعددته بالامس فيه جميع ما طلبت سابقا المرفق الاول وحاولت رفعه ولم استطع 2003-2007 فورم مخصص_1.rar

اخي ابو تميم ---------- حفظك ربي جزاك الله خيرا وبارك فيك بالنسبة لهذه الملاحظات هي على بالي من سابق ولكن اولا رفعت الموجود من الفكرة وايضا يهمني في الدرجة الاولى ان يكون التعديل على الملف مرن للكل الجاهز الان في الملف الذي اعمل عليه اضافة فروع اخرى للزر المضغوط تقبل تحياتي وشكري

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

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

السلام عليكم اخي الحبيب ابو انصار حفظه الله تطبيق رائع جدا للفكرة والله انت روعة فكرا وفهما وعملا ماشاء الله لا قوة الا بالله تقبل تحياتي وشكري

نعم

حسب تتبعك للموضوع اخي عباد اكيد خطرت على بالك الكثير من الافكار والحلول فانت ما شاء الله عليك

السلام عليكم انا كنت اتتبع الموضوع ومنتظر التوضيح منك مثل ما اخبرك اخي النشيط والحبيب ابو انصار عملية حفظ مواقع الليبلات المضافة حديثا اثناء التشغيل تكاد تكون مستحيلة !! لكن ممكن تضيفها في الفورم اثناء التصميم ثم تجعل امكانية تحريكها ممكنه وعند الخروج من الفورم تحفظ عنوان تواجدها في الفورم top-left في جدول معين على الشيت في الملف وفي كود UserForm_Initialize عند فتح الفورم تجعله ياخذ عناوين موقع الليبلات من الجدول هذه الفكره معقولة

اخي حمادة عمر ---------- حفظك ربي اثابك الله بدعائك واعطاك بمثله اضعاف مضاعفة و جزاك خيرا وبارك فيك تقبل تحياتي وشكري

daiy1diary ورقة فيها بيانات اما هذه daily فاضية اين بياناتك ؟؟؟ الاعمدة التي تريد تراكمها اين هي ؟؟ اشرح طلبك مفصلا اخي الكريم

لم نفهم الطلب اشرح طلبك بالتفصيل

اخي dah_med ---------- حفظك ربي اثابك الله بدعائك واعطاك بمثله اضعاف مضاعفة و جزاك خيرا وبارك فيك تقبل تحياتي وشكري

اخي الحبيب الشهابي -----------حفظك ربي مرورك اسعدني و شعرك اطربني اكرمك الله اكرمك الله اكرمك الله و جزاك خيرا وبارك فيك تقبل تحياتي وشكري

اخي االجزيرة -----------حفظك ربي سررت بمرورك جزاك الله خيرا وبارك فيك تقبل تحياتي وشكري

اخي ريان ---------- حفظك ربي اثابك الله بدعائك واعطاك بمثله اضعاف مضاعفة و جزاك خيرا وبارك فيك. اعمل كود واضف اسمه في الجدول في عمود اسم الكود بجانب اسم الامر ضف نيبل بجانب الليبلات حسب العدد الموجود في الفورم 4 اذا الجديد 5 Lb1_5 واعمل جدول مثل الجداول الموجوده وسمي النطاق باسم الليبل واضف كودين ممائلين للموجود في الفورم لليبلات وهما: Private Sub Lb1_5_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) kh_set1 "Lb1_5" kh_AddName Range("Lb1_5") End Sub Private Sub Lb1_5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) kh_set1 "Lb1_5" End Sub بالنسبة للصورة حمل المرفق الذي المشاركة رقم 7 تقبل تحياتي وشكري

اخي ابو ردينة ---------- حفظك ربي اثابك الله بدعائك واعطاك بمثله اضعاف مضاعفة و جزاك خيرا وبارك فيك تقبل تحياتي وشكري

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