Excel - คัดลอกแถวและแทรก n ครั้ง

ปัญหา

ฉันกำลังพยายามสร้างแมโครภายใต้ Excel

ข้อมูลของฉันเป็นดังนี้:

คอลัมน์ 1 คอลัมน์ 2 คอลัมน์ 3 คอลัมน์ 4

Data1 Data1 Name1; Name2; Name3 Data1

Data2 Data2 Name1; Name2; Data2

Data3 Data3 Name1; Name2; Name3 Data3

แต่ละเซลล์ในคอลัมน์ 3 มีจำนวนชื่อที่คั่นด้วยเครื่องหมายอัฒภาค

ฉันต้องการมาโครที่ทำสิ่งเหล่านี้:

1) สร้างจำนวน n แถวหลังแถวแรก N คือจำนวนชื่อในเซลล์ในคอลัมน์แรก 3

2) แยกชื่อในแถวด้านล่าง (คล้ายกับข้อความถึงคอลัมน์)

3) คัดลอกเนื้อหาของเซลล์อื่น ๆ ในแถวเดิมไปยังแถวที่แทรกด้านล่าง

4) ไปยังแถวถัดไปและทำมันทั้งหมดอีกครั้ง

ผลลัพธ์ควรมีลักษณะเช่นนี้:

คอลัมน์ 1 คอลัมน์ 2 คอลัมน์ 3 คอลัมน์ 4

Data1 Data1 Name1 Data1

Data1 Data1 Name2 Data1

Data1 Data1 Name3 Data1

Data2 Data2 ชื่อ 1 Data2

Data2 Data2 Name2 Data2

Data3 Data3 ชื่อ 1 Data3

Data3 Data3 ชื่อ 2 Data3

Data3 Data3 ชื่อ 3 Data3

คุณช่วยฉันออก

สารละลาย

ดาวน์โหลดไฟล์ "duffy.xlsm" จากเว็บเพจนี้ //speedy.sh/ruRSQ/duffy.xlsm

ข้อมูลหลักอยู่ในแผ่นที่ 1 (ไม่มีอัฒภาค) และผลลัพธ์จะเป็นแผ่นที่ 2

มาโครซ้ำที่นี่:

 การทดสอบย่อย () Dim rrow1 เป็น Range, rrow2 เป็น Range, crow2 As String, rcol เป็น Range Dim j ตราบเท่า, k ตราบใด, nname () เป็น String Dim m ในฐานะ Integer, dest As Range, ddata () As String, n แอปพลิเคชันที่ยาว ScreenUpdating = เลิกทำเท็จด้วยเวิร์กชีท ("sheet1") j = .Range ("a1"). End (xlDown) .RD ReDim data (1 ถึง j - 1) สำหรับ k = 2 ถึง j ddata 1) = .Cells (k, คอลัมน์จำนวน) .End (xlToLeft) .Value 'msgbox ddata (k - 1) ตั้งค่า rcol = Range (.Cells (k, "C"), .Cells (k, "c" ). สิ้นสุด (xlToRight) .Offset (0, -1)) 'msgbox rcol.Address m = WorksheetFunction.CountA (rcol)' msgbox m เปลี่ยนชื่อ n (1 ถึง m) สำหรับ n = 1 ถึง m n ชื่อ (n) = rcol (1, n) 'msgbox nname (n) ถัดไป n' msgbox rcol. ช่วงที่อยู่ (. เซลล์ (k, "A"), .Cells (k, "B")) คัดลอกด้วยแผ่นงาน ("แผ่น 2") dest = .Cells (Rows.Count, "A"). End (xlUp) .Offset (1, 0) 'msgbox dest.Address ช่วง (dest, dest.Offset (m - 1, 0)) PasteSpecial สำหรับ n = 1 ถึง m dest.Offset (n - 1, 0) .Offset (0, 2) = nname (n). เซลล์ (dest.Offset (n - 1, 0) .Row, Columns.Count) .End (xlToLeft) .Offset (0, 1) = ddata (k - 1) Nex t n จบด้วย Next k จบด้วย Application.ScreenUpdating = Application.CutCopyMode จริง = มาโคร MsgBox เท็จเหนือ "End Sub Sub เลิก () แผ่นงาน (" แผ่นงาน 2 ") Cells.Clear End Sub

ขอบคุณ venkat1926 สำหรับคำแนะนำนี้

บทความก่อนหน้านี้ บทความถัดไป

เคล็ดลับยอดนิยม