طارق محمود

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

السلام عليكم معذرة لاأعرف مفاتيح شركتي زين أو الوطنية ولكن يمكنك إستخدام المعادلة =LEFT(A2,3)&B2&RIGHT(A2,7) أنظر المرفق change Numbers.rar

أخي العزيز أعتذر لابد أن أترك المكتب الآن وقد رأيت ردك حالا إن لم يتدخل احد الإخوة حتي السبت بإذن الله سأحلها لك عذرا

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

مرفق فيديو لتوضيح كيفية عمل ذلك عل 2010 للأسف ليس عندي الآن 2007 ASSIGN_Macro2.rar

السلام عليكم بعد إذن إخواني المشاركين أعتقد ان الأخ السائل يريد جدولة البيانات محوريا أخي الكريم أنظر المرفق باستخدام الجداول المحورية Pivot Tables sam.rar

عفوا لم أفهم إن كنت تقصد إخفاء ظهور اسماء الشيتات من Tools Options View Windows Options إمسح العلامة أمام الـ Sheet Tabs

يفضل عمل زر إختصار بدل الزر في هذه الحالة قبل تسجيل الملف كما سبق في الشرح إضغط Alt-F8 سيظهر لك اسم الماكرو من Options إختر زر وليكن k مثلا ليسهل عليك استدعاء الماكرو فيما بعد عن طريق ضغط Ctrl مع k

في هذه الحالة تسجل نسخة من الملف الذي به الماكرو كملحق من ملحقات الإكسل علي جهازك أي Add-In لو كنت تستخدم 2003 فستجد خيار التسجيل هذا في آخر خيارات حفظ بإسم Save As وسينتج عنه نسخة من الملف بامتداد xla وليس xls وستحفظ في فولدر الإكسل وستجد إسم هذا الملف موجود في قائمة الـ Add-In التي تجدها في Tools > Add-In ويكون هذا الملف بما فيه من ماكروهات قيد التنفيذ مع الإكسل بشرط تنشيطه من تلك القائمة

السلام عليكم أخي الكريم مافيش إزعاج أبدا يجوز عمل الربط علي الصورة أو الأشكال الجاهزة بالأوفيس وطريقة الربط واحدة كليك بالماوس يمين علي الشكل او الصورة ثم إختر Assign Macro ستجد قائمة بها أسماء الماكروهات المتاحة ، كليك علي ماتشاء منها مرفق فيديو للتوضيح في الكود الذي بالملف والموجود أيضا في المشاركة #6 من هذا الموضوع إستبدل كل كلمة Book1 باسم الملف الذي تريد وهي موجودة 3 مرات في الكود مثلا لو الملف إسمه SHAR.xls فيكون الكود كالتالي Sub Shift_Data() ' ' Macro2 Macro ' Macro recorded 09/11/2010 by web Dim file_1 As String On Error Resume Next file_1 = ActiveWorkbook.Path & "\SHAR.xls" 'هنا Workbooks.Open Filename:=file_1 Workbooks("SHAR.xls").Activate 'هنا z = Range("B1", [E1000].End(xlUp)).Rows.Count For j = 1 To z x = "" For i = 1 To 4 x = x & " " & Cells(j, 1 + i) Next i Range(Cells(j, 3), Cells(j, 5)).Clear Cells(j, 2) = x Next j Range("A1", "B" & z).Copy Workbooks("SHAR.xls").Close False 'هنا Workbooks("Book2.xls").Activate [A2].Select ActiveSheet.Paste [A2].Select End Sub مع التحية ASSIGN_Macro.rar

السلام عليكم هذا هو الكود Sub Macro1() ' ' Macro1 Macro ' Dim compn As Range, x(999) As String 'On Error Resume Next Worksheets("Sheet1").Select Set compn = Range("C3", [C10000].End(xlUp)) i = 0 ' counter For Each c In compn ' Company names i = i + 1 ' counter For j = 1 To i If x(j) = c.Value Then i = i - 1: GoTo 100 Next j x(i) = c.Value 100 Next c cmp_Nu = i ' total Company number wshs = Worksheets.Count For i = 1 To cmp_Nu For j = 1 To wshs If Worksheets(j).Name = x(i) Then GoTo 200 Next j add_n_sht (x(i)) 'in case no sheets in this name 200 Next i Sheets("sample").Visible = Hidden Sheets("Sheet1").Select Qaid_No = [A10000].End(xlUp).Row - 2 Last_sh = [A1].Value ' Last shifted 'Copy & Paste the Data For qq = Last_sh + 1 To Qaid_No c_nam = Range("C" & qq + 2).Value Range("A" & qq + 2, "Q" & qq + 2).Copy Sheets(c_nam).[A10000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteFormulas [A1].Value = [A1].Value + 1 Next qq Application.CutCopyMode = False [B3].Select End Sub Function add_n_sht(n_sht) Sheets("sample").Visible = True Sheets("sample").Select 'in case no sheets in this name wshs = Worksheets.Count Sheets("sample").Copy Before:=Sheets(wshs) ActiveSheet.Name = n_sht [C1].Value = n_sht End Function مع ملاحظة أن الخلية A1 تحتوي علي 0 أي عدد القيود (البيانات) المرحلة =0 مثلا لو عندك 12 بيان وضغطت الزر لترحيلهم سيكون قيمة الخلية A1 = 12 بعد ترحيلهم ثم أضفت 8 بيانات أخري حتي 20 وضغطت الزر للترحيل مرة أخري فلن يرحل إلا البيانات من 13 إلي 20 وسيكون قيمة الخلية A1 = 20 بعد ترحيلهم وهكذا وطبعا تستطيع يدويا تغيير قيمة هذه الخلية A1 لترحيل البيانات مثلا بداية من البيان كذا أو كذا تفضل المرفق وبه الكود yehia.rar

أبشر أخي يحي إن شاء الله سأرفق الحل قريبا

السلام عليكم مرفق الفولدر به الملف وبه الكود وأيضا فيديو توضيحي لاداعي للتظليل ، فقط إضغط الزر ستلاحظ أن بعض الملفات لم يتم نسخها وذلك لاأدري لماذا قد يكون لأن أسماءها تحتوي علي علامات خاصة مثلا أو الإسم متكرر بمعني أن لديك 240 ملف والكود ينسخ فقط 231 أيضا عندي ملحوظة جميع الملفات ستكون بأسماء مختلفة لكن طبعا بياناتها من الداخل واحدة أي انها جميعا تحتوي علي نفس البيانات التالية: EmpID: 34271 Name: Saadeldin mahfooz salem salem Hassan Position: Electrical engineer Department: Technical Cost center: X 31000CB فلو أنك عندك جدول مثلا لبيانات مختلفة لعدد من الموظفين فمن الممكن إنشاء الملفات مباشرة بنفس التنسيق وبالبيانات الجديدة Upload2.rar

الكود الجديد هو Private Sub CommandButton1_Click() On Error Resume Next org_file = ActiveWorkbook.Path & "\" & [B2] Range("C2", [C1000].End(xlUp)).Select For Each i In Selection FileCopy org_file, i.Value Next i End Sub

أنت لم توضح ذلك سابقا المهم إن شاء الله سأنشيء لك كود قريبا بما تريد

السلام عليكم كود نقل البيانات في هذه الحالة ممكن يكون كالتالي Sub Shift_Data() ' ' Macro2 Macro ' Macro recorded 09/11/2010 by web Dim file_1 As String On Error Resume Next file_1 = ActiveWorkbook.Path & "\Book1.xls" Workbooks.Open Filename:=file_1 Workbooks("Book1.xls").Activate z = Range("B1", [E1000].End(xlUp)).Rows.Count For j = 1 To z x = "" For i = 1 To 4 x = x & " " & Cells(j, 1 + i) Next i Range(Cells(j, 3), Cells(j, 5)).Clear Cells(j, 2) = x Next j Range("A1", "B" & z).Copy Workbooks("Book1.xls").Close False Workbooks("Book2.xls").Activate [A2].Select ActiveSheet.Paste [A2].Select End Sub مرفق الملف Book2.xls وبه الكود Book2.rar

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

مرفق المجلد بعد تعديل الملف ومعه فيديو أيضا للتوضيح Upload.rar

السلام عليكم< ضع الكود التالي في الملف CopyFile.xls Sub cc() For Each i In Selection On Error Resume Next oldfile = ActiveWorkbook.Path & "\" & i.Value newfile = i.Offset(0, 1).Value FileCopy oldfile, newfile Next i End Sub ثم ظلل علي الخلايا التي بها الملفات المراد نسخها شرط أن تكون في نفس المجلد الذي به الملف CopyFile.xls

السلام عليكم إستحدثت لك دالة بسيطة countcolor صيغتها countcolor(x, c) حيث x مجال البحث c أي خلية ذات اللون الذي تريد عده كود الدالة كالتالي Function countcolor(x, c) y = 0 a = c.Interior.ColorIndex For Each cell In x b = cell.Interior.ColorIndex If b = a Then y = y + 1 Next cell countcolor = y End Function مرفق ملفك وبه تطبيق الدالة 1245684.rar

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

السلام عليكم أخي العزيز كونت لك دالتين تم تفصيلهم خصيصا لهذا الملف الدالة الأولي dasan تلتقط إجمالي الأطوال من البيانات وتجمعها إن تكرر إسم الداسان (ت1 أو ت2 أو ...) وهذا هو كودها حيث x هو إسم الداسان Function dasan(x) As Variant y = 0 For r = 6 To 30 Step 6 For j = 1 To 22 Step 3 s = Cells(r + 5, j) If Cells(r, j) = x Then y = y + s Next j Next r dasan = y End Function والثانية تجمع أعداد الألوان بمعلومية متغيرين إسم الداسان ، اللون وهذا هو كودها حيث x هو إسم الداسان ، c هو اللون Function d_Color(x, c) As Variant y = 0 For r = 6 To 30 Step 6 For j = 1 To 22 Step 3 If Cells(r, j) = x Then For cl = 1 To 4 If Cells(r + cl, j + 1) = c And Cells(r + cl, j) > 0 Then y = y + 1 Next cl End If Next j Next r d_Color = y End Function وهذا هو المرفق kazan soft.rar

السلام عليكم أسرع وسيلة فلتر ثم إختار اللافارغ Nonblank ثم نسخ لكن اللصق لابد أن يكون في غير مجال الفلتر

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

السلام عليكم أخي العزيز عندك التنسيق الخاص بخلية التجميع hh:mm غيره بوضع الـ hh بين قوسين [] ليكون هكذا [hh]:mm