مداد_1423

للرفع ... وللتذكير بالصلاة والسلام على رسول الله صلى الله عليه وعلى آله وصحبه وسلم

للرفع ... وفي الرفع نفع إذا تكرمتم يا كرام.. مفاتيح البحث عن كود مشابه يرحل مجموعة صفوف بناء على الخلية الأولى في الصف وأنا إن شاء الله أعدل على الكود وأعيد نشره لتعم الفائدة تحياتي

رائع أستاذنا ، رائع بارك الله فيك وكثر من أمثالك مبدع وعقلية جبارة الله يحفظك ويزيدك من فضله احتاج هذا الملف كل أسبوع تحياتي يا كبير

السلام عليكم ورحمة الله تحية لكم يا كرام عندي ملفين (ملف فيه بيانات بعض الموظفين غير مرتبين ) أريد ترحيل صف بيانات الموظف من العامود A:AG إلى الملف الثاني في شيت Overtime على حسب رقم الموظف في العامود A ملاحظة: لا يوجد تكرار في رقم الموظف سواء في المصدر أو الهدف فما له داعي وضع شرط تكرار ملاحظة: الملفين في مجلد واحد ولا يمكن أن يكون في نفس المجلد ملفات أخرى لا إكسل ولا غيره بحثت في المنتدى وغيره ما وجت ترحيل مجموعة صفوف على حسب رقم الموظف مع الشكر مقدماً لكل من مر هنا وأخص من ساعدني بالدعاء والشكر تحياتي OT_2_DE..xlsx Q.c.xlsx

حدد صف العناوين وصف (أو صفوف) تحته ثم من قائمة إدراج بالأعلى اختر (جدول) الثالثة من اليمين تقريبا وتستطيع الوصول له من خلال لوحة المفاتيح بالضغط على CTRL+L تحياتي

الأستاذ: نبيل عبدالهادي جزاك الله خيراً ، ومتعك الله بصحتك وبارك في عمرك ووقتك وأدام لك السعادة كفيت ووفيت ، هذا المطلوب << شكر من الأعماق ، ودعوة في آخر الليل كثر الله من أمثالك تحياتي

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

السلام عليكم طابت أوقاتكم يا سادة باختصار عندي ملف أحتاجه مع ثلاثين قسم في عملي في كل شهر الملف الذي يصلني من الأقسام عليه باسوورد حماية (123)ـ أحتاج أنسخ ثلاث شيتات من الملف المحمي سويت ماكرو لكن فيه مشكلتين الأولى: الماكرو ما يكتب الباسوورد فأضطر لفتح الملف وفك الباسوورد قبل تفعيل الماكرو الثانية: لازم يبقى الملف في نفس المسار ، وأنا أتمنى يكون فولدر لكل شهر الشيتات التي أريد نسخها من ملف باسم رقم واحد في فولدر Files إلى ملف HR_TESTER Shift Schedule & Overtime & Attendance تحياتي لكل من مر من هنا وأخص من ساعدني بالشكر والدعاء HR_TESTER.xlsm 1.xlsm

بارك الله فيك عمل مفيد جدا للكثير ابداع ليس غريب عليك تحياتي

تم الحل بعد محاولات وتجارب لكن حصل المقصود لكم الشكر يا سادة Sub copy_data() Dim S As Worksheet: Set S = Sheets("ALL") Dim Q As Worksheet: Set Q = Sheets("Shift Schedule") Dim O As Worksheet: Set O = Sheets("Overtime") Dim A As Worksheet: Set A = Sheets("Attendance") Dim Final_Q: Final_Q = Q.Cells(Rows.Count, 1).End(3).Row Dim Final_S: Final_S = S.Cells(Rows.Count, 1).End(3).Row Dim Final_O: Final_O = O.Cells(Rows.Count, 1).End(3).Row Dim Final_A: Final_A = A.Cells(Rows.Count, 1).End(3).Row Dim RQ As Range: Set RQ = Q.Range("A8:AG" & Final_Q) Dim Rs As Range: Set Rs = S.Range("A8:AG" & Final_S) Dim RO As Range: Set RO = O.Range("A8:AG" & Final_O) Dim RA As Range: Set RA = A.Range("A8:AG" & Final_A) Dim i%, XQ, xO%, XA%, xx% XQ = RQ.Rows.Count: xO = RO.Rows.Count: XA = RA.Rows.Count Rs.ClearContents i = 1: xx = 8 Do Until i > XQ S.Cells(xx, 1) = RQ.Cells(i, 1) S.Cells(xx, 3).Resize(, RQ.Columns.Count - 2).Value = _ RQ.Cells(i, 3).Resize(, RQ.Columns.Count - 2).Value i = i + 1: xx = xx + 3 Loop i = 1: xx = 9 Do Until i > xO S.Cells(xx, 1) = RO.Cells(i, 1) S.Cells(xx, 3).Resize(, RO.Columns.Count - 2).Value = _ RO.Cells(i, 3).Resize(, RO.Columns.Count - 2).Value i = i + 1: xx = xx + 3 Loop i = 1: xx = 10 Do Until i > XA S.Cells(xx, 1) = RA.Cells(i, 1) S.Cells(xx, 3).Resize(, RA.Columns.Count - 2).Value = _ RA.Cells(i, 3).Resize(, RA.Columns.Count - 2).Value i = i + 1: xx = xx + 3 Loop End Sub

تحية طيبة وبعد:- أتمنى يكون الجميع بصحة وسلامة لدي ملف في كود من إبداع أستاذنا سليم حاصبيا المطلوب إضافة شيت جديد بحيث يكون ترتيب التجميع في شيت ALL أولا: Shift Schedule ثانيا: Overtime ثالثا: Attendance ويكون التجميع بيانات من غير تنسيق إذا أمكن مع الشكر لكل من مر هنا وأخص بالشكر والدعاء من ساعدني تحياتي Option Explicit Sub copy_data() Dim S As Worksheet: Set S = Sheets("ALL") Dim O As Worksheet: Set O = Sheets("Overtime") Dim A As Worksheet: Set A = Sheets("Attendance") Dim Final_S: Final_S = S.Cells(Rows.Count, 1).End(3).Row Dim Final_O: Final_O = O.Cells(Rows.Count, 1).End(3).Row Dim Final_A: Final_A = A.Cells(Rows.Count, 1).End(3).Row Dim Rs As Range: Set Rs = S.Range("A8:AG" & Final_S) Dim RO As Range: Set RO = O.Range("A8:AG" & Final_O) Dim RA As Range: Set RA = A.Range("A8:AG" & Final_A) Dim i%, xO%, XA%, xx% xO = RO.Rows.Count: XA = RA.Rows.Count Rs.ClearContents i = 1: xx = 8 Do Until i > xO S.Cells(xx, 1) = RO.Cells(i, 1) S.Cells(xx, 3).Resize(, RO.Columns.Count - 2).Value = _ RO.Cells(i, 3).Resize(, RO.Columns.Count - 2).Value i = i + 1: xx = xx + 2 Loop i = 1: xx = 9 Do Until i > XA S.Cells(xx, 1) = RA.Cells(i, 1) S.Cells(xx, 3).Resize(, RA.Columns.Count - 2).Value = _ RA.Cells(i, 3).Resize(, RA.Columns.Count - 2).Value i = i + 1: xx = xx + 2 Loop End Sub HR_TEST1.xlsm

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

أستاذنا : علي بارك الله فيك ومتعك بصحتك وأسبغ عليك نعمه أولاً أشكرك لأني عرفت كيف أعين الشيت الذي أريد من عدة شيتات في الملف لكن الكود لا يقوم بالمطلوب جربت فصلت الكود ودمجتهم ما نفع Sub MACROS() Call Macro2 Call Macro1 End Sub لكن لمن أشغل كل كود وحدة تكون النتيجة صحيحة للعلم : الشرط في خلية AP3 أكبر من 79 يكون فيه اعتماد لاحظ المرفق HR_TEST2.xlsm

تحية طيبة آمل أن يكون طلبي خفيف على حضراتكم لدي كود يعمل بكفاءة وهذا هو Sub Macro1() Dim i As Integer, m As Integer Application.ScreenUpdating = False For i = 2 To 4 With ThisWorkbook.Worksheets(i) m = .Cells(Rows.Count, 1).End(xlUp).Row If i <> 3 Then .Range("A1:AH" & m).PrintOut Copies:=1, Collate:=True ElseIf i = 3 Then If .Range("AH" & .Cells(Rows.Count, "AH").End(xlUp).Row).Value > 0 Then .ListObjects("HR_2").Range.AutoFilter Field:=34, Criteria1:=">0" .Range("A1:AH" & m + 1).PrintOut Copies:=1, Collate:=True .ListObjects("HR_2").Range.AutoFilter End If End If End With Next i Application.ScreenUpdating = True End Sub أريد أن أضيف هذا السطر بحيث يكون فعال في شيت (Overtime) فقط ActiveSheet.PageSetup.RightFooter = Range("AP3").Value لأني أريد أن يظهر الشرط الموجود في خلية AP3 في الركن الأيمن في تذييل الصفحة الكود اختبرته على ملف من شيت واحد وفعال ولكن ما عرفت أضيفه على شيت الأوفرتايم ملاحظة: الكود يقوم بطباعة جميع الشيتات ، لذا وجب التنبيه تحياتي HR_TEST2.xlsm

وعليكم السلام ورحمة الله وبركاته أولاً: جزاك الله خيرا ، وشكر الله لك ومتعك بصحتك ثانياً : أعتذر عن التأخير لبعدي عن الكمبيوتر في الإجازة الأسبوعية ثالثاً: ما أدري أنا ما عرفت استخدم الكود أو أن الكود ناقصه شيء الصورة المتحركة يظهر فيها أن كلمة أبروف متواجدة سواء كان فيه قيمة أكثر من 60 أو لم يوجد شيء

يستاهل كل خير أبارك لك اللقب الذي تستحقه عن جدارة تحياتي

السلام عليكم جميعاً تحية طيبة عندي ملف للعمل الإضافي أضفت عليه تذييل صفحة تظهر عند الطباعة السؤال : بغيت أضيف اعتماد (Approve) إذا زادت قيمة مجموع الصف 60 أو أكثر (عامود AH) داخل الجدول طبعا وليست المجموع النهائي سواء بكود أو خلية مساعدة أو أي طريقة شكرا لك من مر من هنا وأخص بالشكر والدعاء من ساعدني على حل المشكلة تحياتي Ot.xlsx

في خلية B1 جرب تغير نص الخلية من Government Exp إلى Government_Exp بحيث تستبدل المسافة بالشرطة السفلية وبتزبط معك المشكلة عندك في تسمية صف العناوين (المسافات) تحياتي

تحية طيبة مباركة للجميع أدام الله عليكم لباس الصحة جميعا وجدت كود للأستاذ سليم حاصبيا لتجميع البيانات من الشيتات إلى شيت رئيسي وهو كود رائع وسريع لكن ما قدرت أعدل عليه حتى يعمل مع الملف عندي الكود: Sub Give_ALL_Data() Dim Arr_sh(), i%, m%: m = 2 Dim Arr_counte() For i = 1 To Sheets.Count - 3 ReDim Preserve Arr_sh(1 To i) ReDim Preserve Arr_counte(1 To i) Arr_sh(i) = Sheets(i).Name Arr_counte(i) = Application.Max(Sheets(i).Range("a:a")) Next Sheets("ALL").Range("A3:AH1000").ClearContents For i = LBound(Arr_sh) To UBound(Arr_sh) Sheets("ALL").Range("A" & m).Resize(Arr_counte(i), 8).Value = _ Sheets(Arr_sh(i)).Range("A3").Resize(Arr_counte(i), 8).Value m = m + Arr_counte(i) + 1 Next Erase Arr_sh: Erase Arr_counte End Sub المطلوب تختصره الصورتين أولاً: ثانياً: لكل من مر من هنا تحية ولكل من ساعدني دعوة خالصة وشكرا من الأعماق تحياتي TEST_ _HR.xlsm

بحمد الله تمكنت من التعديل على الكود الأول (تجميع شيت من عدة ملفات في فولدر) والكود يعمل بكفاءة عالية ولله الحمد Sub CollectWorkbooks() Dim Path As String Dim Filename As String Dim SH As Worksheet Dim X As Long X = 2 Path = ThisWorkbook.Path & "\Files\" Filename = Dir(Path & "*.xlsm") Application.ScreenUpdating = False Application.DisplayAlerts = False For Each SH In ThisWorkbook.Sheets If SH.Name <> "Nep_HR" And SH.Name <> "ALL" Then SH.Delete Next SH Do While Filename <> "" Workbooks.Open Filename:=Path & Filename, ReadOnly:=True For Each SH In ActiveWorkbook.Sheets If SH.Name <> "Overtime" Then GoTo 1 SH.Copy After:=ThisWorkbook.Sheets(X) X = X + 1 1 Next SH Workbooks(Filename).Close Filename = Dir() Loop Sheets("Nep_HR").Activate Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub بقي التعديل على الكود الثاني وهو تجميع بيانات ملف في شيت واحد تجمع البيانات في شيت ALL بدءًا من الخلية A3 بحيث بيانات العامود A من الشيتات الأخرى تكون في العامود A والعامود C من الشيتات الأخرى تكون في العامود B الكود الذي أريد التعديل عليه بناء على من وضحته في هذه المشاركة بالصور أعلاه Sub Give_ALL_Data() Dim Arr_sh(), i%, m%: m = 2 Dim Arr_counte() For i = 1 To Sheets.Count - 3 ReDim Preserve Arr_sh(1 To i) ReDim Preserve Arr_counte(1 To i) Arr_sh(i) = Sheets(i).Name Arr_counte(i) = Application.Max(Sheets(i).Range("a:a")) Next Sheets("ALL").Range("A3:AG1000").ClearContents For i = LBound(Arr_sh) To UBound(Arr_sh) Sheets("ALL").Range("A" & m).Resize(Arr_counte(i), 8).Value = _ Sheets(Arr_sh(i)).Range("A3").Resize(Arr_counte(i), 8).Value m = m + Arr_counte(i) + 1 Next Erase Arr_sh: Erase Arr_counte End Sub ملاحظة : فولدر فايل في المشاركة الرئيسية لمن أراد أن يستفيد من تجميع شيت من عدة ملفات TEST__HR.xlsm

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

من لوحة المفاتيح اضغط على زر Home ثم اضغط Backspace وستصعد الكتابة إلى أعلى إن شاء الله

تحية طيبة للجميع بداية أشكر كل من في هذا المنتدى الذي استفدت منه كثيرا أشكر الأستاذ: ياسر خليل أبو البراء على كود دمج الملفات في ملف واحد والذي أخذته من هذا الموضوع والكود يعمل بكفاءة عالية ، المطلوب : 1) قبل الدمج تحذف جميع الشيتات ما عدى أول وثاني شيت 2) تعديل الكود بحيث يجمع فقط شيت Overtime فقط وليس كل الشيتات ==== ثانياً: أشكر الأستاذسليم حاصبيا على كود تجميع البيانات من شيتات إلى شيت واحد في هذه المشاركة المطلوب: 1) حذف بيانات شيت ALL من A3:AF1000 كما في الصورة 2) تجميع بيانات الشيت من A8 إلى آخر خلية فيها بيانات من نفس العامود إلى العامود AG باستثناء العامود B لا أريد أن يكون في التجميع صورة توضيحية أتمنى ما يكون طلبي ثقيل على حضراتكم مع الشكر لكل من مر هنا ، وأخص بالشكر والدعاء من ساعدني والله يقدرنا على رد فضلكم علينا وهنيئا لصاحب العلم زكاة علمه تحياتي TO_Officena.rar

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