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 01 999999 SMITH 27 02 10 I1 01 999 10 SM1 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 บันทึกไฟล์
นี่คือรหัส
รายละเอียดย่อย () Dim thisWB เป็น String Dim newWB เป็น String thisWB = ActiveWorkbook.Name เมื่อเกิดข้อผิดพลาดต่อไปแผ่นงานถัดไป ("tempsheet") ลบข้อผิดพลาด GoTo 0 แผ่นเพิ่ม ActiveSheet.Name = "Tempsheet" แผ่นงาน ("Sheet1") เลือกถ้า ActiveSheet.AutoFilterMode แล้ว Cells.Select ในข้อผิดพลาดกลับมาทำงานต่อไป ActiveSheet.ShowAllData ตามข้อผิดพลาดไปที่ 0 สิ้นสุดหากคอลัมน์ ("B: B") เลือก Selection.Copy Sheets ("tempsheet") เลือกช่วง ("A1") เลือก ActiveSheet.Paste Application.CutCopyMode = False ถ้า (เซลล์ (1, 1) = "") จากนั้น lastrow = เซลล์ (1, 1) .End (xlDown) .Row ถ้า lastrow แถวนับช่วงแล้ว ("A1: A" & lastrow - 1) เลือกการเลือกลบ Shift: = xlUp สิ้นสุดหากสิ้นสุดหากคอลัมน์ ("A: A") เลือกคอลัมน์ ("A: A") แอ็คชัน AdvancedFilter: = xlFilterCopy, _ CopyToRange: = ช่วง (" B1 "), ไม่ซ้ำกัน: = คอลัมน์ที่แท้จริง (" A: A "). ลบเซลล์การเลือก Select.Sort _ Key1: = ช่วง (" A2 "), Order1: = xlAscending, _ ส่วนหัว: = xlYes, OrderCustom: = 1, _ MatchCase: = False, การวางแนว: = xlTopToBottom, _ DataOption1: = xlSortNormal lMaxSupp = เซลล์ (Rows.Count, 1) .End (xlUp) .Row for s uppno = 2 เพื่อ lMaxSupp Windows (thisWB) เปิดใช้งาน supName = แผ่นงาน ("tempsheet") ช่วง ("A" & suppno) ถ้า supName "" จากนั้นสมุดงานเพิ่ม ActiveWorkbook.SaveAs supName newWB = ActiveWorkbook.Name Windows (thisWBB) เปิดใช้งานชีต ("Sheet1") เลือก Cells.Select ถ้า ActiveSheet.AutoFilterMode = False จากนั้น Selection.AutoFilter สิ้นสุดถ้า Selection.AutoFilter ฟิลด์: = 2, Criteria1: = "=" & supName, _ ผู้ดำเนินการ: = xlAnd, Criteria2: = "" lastrow = เซลล์ (Rows.Count, 2) .End (xlUp). แถว Rows ("1:" & lastrow) .Copy Windows (newWB). เปิดใช้งาน ActiveSheet.Paste ActiveWorkbook บันทึก ActiveWorkbook ปิดท้ายหากแผ่นงานถัดไป ( "tempsheet") ลบแผ่นงาน ("Sheet1") เลือกถ้า ActiveSheet.AutoFilterMode จากนั้นเลือก Cells.Select ActiveSheet แล้วแสดง AllData End ถ้า End Sub ขอบคุณ Rizvisa1 สำหรับเคล็ดลับนี้