Excel - ماكرو لإنشاء مصنف جديد ونسخ البيانات
القضية
أنا أبحث عن الماكرو لنسخ الصفوف بناءً على محتوى خلية جزئي لعمود. لدي جدول بيانات excel يسمى "arc.xlsx" أود منه نسخ البيانات إلى ملفات excel القليلة الجديدة عند استيفاء معايير معينة. ملف excel المتضمن هو C: \ Documents and Settings \ xxxx \ Desktop \ Company. أنا فقط مبتدئ في Excel.
يوجد أدناه عينة من arc.xlsx
GP BR CUST_NO CUST_NAME يوم مو عام I1 01 999999 SMITH 00 08 09 I1 ab 999999 SMITH 04 08 09 I1 cd 999999 SMITH 04 10 09 I1 01 999999 SMITH 04 01 10 I1 02 999999 SMITH 27 02 10 I1 01 999999 SMITH 27 02 10 I1 cd 999999 SMITH 02 03 10 I1 cd 999999 SMITH 04 03 10 I1 cd 999999 SMITH 30 07 09 I1 ab 999999 SMITH 30 07 09 I1 02 999999 SMITH 30 07 09
- أرغب في نسخ الماكرو للصفوف التي تحتوي على "ab" في العمود B (مع العنوان BR) وحفظه في ملف excel جديد يحمل الاسم ab.xlsx في مجلد الموقع نفسه.
- ونفس الشيء بالنسبة لـ "cd" و "01" و "02" عن طريق حفظ البيانات في الملفات التي تحمل اسم cd.xlsx و 01.xlsx وما إلى ذلك.
حل
1. قم بعمل نسخة احتياطية من كتاب العمل الخاص بك
2. افتح كتاب العمل
3. اضغط ALT + F11 (كل من مفتاح ALT ومفتاح F11 في نفس الوقت). هذا فتح VBE
4. من قائمة VBE ، انقر فوق "إدراج" ثم اختر "الوحدة النمطية" بالنقر فوقها. هذا سيفتح وحدة فارغة
5. انسخ الكود الذي قدم بعد التعليمات عن طريق اختيار الكود (سيتم العثور عليه بعد التعليمات) وضغط CTRL + C (كلا المفتاحين في نفس الوقت)
6. الصق الشفرة في الوحدة النمطية المضافة حديثًا (انظر الخطوة 4) بالنقر فوق الوحدة النمطية وضغط CTRL + V (مرة أخرى في نفس الوقت)
7. تأكد من عدم وجود خط أحمر في الكود الملصق.
8. اضغط F5 لتشغيل الماكرو.
9 راجع المستندات في الموقع الافتراضي حيث يحفظ excel بشكل عام الملف.
هنا هو الكود
التفاصيل الفرعية () تعتيم thisWB باسم String dim newWB باسم String thisWB = ActiveWorkbook.Name On Error استئناف الصفائح التالية ("tempsheet"). احذف On Error GoTo 0 Sheets.Add ActiveSheet.Name = "tempsheet" Sheets ("Sheet1"). حدد If ActiveSheet.AutoFilterMode ثم Cells.Select On Error استئناف التالي ActiveSheet.ShowAllData On Error GoTo 0 End If Columns ("B: B"). Selection.Copy Sheets ("tempsheet"). حدد Range ("A1"). حدد ActiveSheet.Paste Application.CutCopyMode = False If (Cells (1، 1) = "") ثم lastrow = الخلايا (1 ، 1). End (xlDown) .Row If lastrow Rows.Count Then Range ("A1: A" & lastrow - 1). حدد التحديد. حذف الحذف: = xlUp End If End If Column ("A: A"). حدد Columns ("A: A"). AdvancedFilter Action: = xlFilterCopy، _ CopyToRange: = Range (" B1 ") ، فريد: = أعمدة True (" A: A "). احذف Cells.Select Selection.Sort _ Key1: = Range (" A2 ") ، Order1: = xlAscending ، _ Header: = xlYes ، OrderCustom: = 1 ، _ MatchCase: = False، Orientation: = xlTopToBottom، _ DataOption1: = xlSortNormal lMaxSupp = خلايا (Rows.Count ، 1). End (xlUp) .Row For s uppno = 2 إلى lMaxSupp Windows (thisWB). تنشيط supName = الأوراق ("tempsheet"). النطاق ("A" & suppno) إذا supName "" ، ثم Workbooks.Add ActiveWorkbook.SaveAs supName newWB = ActiveWorkbook.Name Windows (thisWB). تنشيط الأوراق ("Sheet1"). حدد Cells.Select If ActiveSheet.AutoFilterMode = False ثم Selection.AutoFilter End If Selection.AutoFilter Field: = 2، Criteria1: = "=" & supName، _ Operator: = xlAnd، Criteria2: = "" lastrow = Cells (Rows.Count، 2). End (xlUp) .Row Rows ("1:" & lastrow) .Copy Windows (newWB). قم بتنشيط ActiveSheet.Paste ActiveWorkbook.Save ActiveWorkbook.Close End If Next Sheets Sheets ( "tempsheet") .حذف الأوراق ("Sheet1"). حدد If ActiveSheet.AutoFilterMode ثم Cells.Select ActiveSheet.ShowAllData End If End Sub بفضل Rizvisa1 لهذه النصيحة.