การคัดลอกข้อมูล จากหลายแผ่นงาน (sheet) มาไว้ที่ sheet เดียวกัน ของ Excel 2007/2010
การคัดลอกข้อมูล จากหลายชีท มาไว้ที่ชีทเดียวกัน ใน Excel ต้องใช้ VBA เข้าช่วย จะใช้สูตรอย่างเดียวไม่พอแน่
ดาวน์โหลดไฟล์ Excel มาศึกษาดูก่อน คลิกที่นี่ (ไฟล์ Excel 2007/2010)
สมมุติว่า มีข้อมูลอยู่ 2 แผ่นงาน ให้ผู้ใช้เลือก เมื่อเลือกเสร็จแล้ว ให้ไปที่แผ่นงานสุดท้าย และคลิกปุ่มรวมข้อมูลที่เลือก โปรแกรม จะไปรวมข้อมูลที่เลือกจากทุกแผ่นงาน มาแสดงไว้ที่แผ่นงานสุดท้าย
แผ่นงานแรก ชื่อ หมวดที่ 1 มีรูปแบบดังนี้
ผู้ใช้เลือกรายการที่ 3 และรายการที่ 8
แผ่นงานที่ 2 ชื่อ หมวดที่2 มีรูปแบบและข้อมูลดังนี้
ผู้ใช้เลือกรายการที่ 2, 4, 7 และรายการที่ 9
ไปที่หน้า สุดท้าย แผ่นงาน สรุป และเมื่อกดปุ่ม จะได้ข้อมูล ดังนี้
จะเห็นว่า ในหน้านี้ นำข้อมูลเฉพาะที่ผู้ใช้เลือก ในแผ่นงาน หมวดที่ 1 และ หมวดที่ 2 มาไว้ที่นี่
ถ้าต้องการแก้ไข หรือดูโค้ด ให้คลิกขวาที่ปุ่ม และเลือก กำหนดแมโคร และคลิกแก้ไข
โค้ดที่เขียนที่ปุ่ม มีดังต่อไปนี้
Sub summary()
' จากเว็บ http://www.thongjoon.com หรือ http://tjkh.blogspot.com
' โดย ทองจุล ขันขาว
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim sheetArray(1 To 100)
Dim i As Integer
Dim totalSheets As Integer
Dim myfirstRowToCopy As Integer
Dim myNum as String
Dim myColName as String
Dim summarySheet as String
On Error GoTo Err_Execute
' ระบุชื่อ sheet ที่มีข้อมูล ที่จะนำไปรวมกันใน sheet สุดท้าย เพิ่มได้ถึง 100 sheets
sheetArray(1) = "หมวดที่1"
sheetArray(2) = "หมวดที่2"
'sheetArray(3) = "....."
'sheetArray(4) = "....."
'ระบุตำแหน่งข้อมูลแถวแรกที่ต้องการให้คัดลอก
myfirstRowToCopy = 2
'ชื่อคอลัมน์ที่มีข้อมูล ใช้สำหรับวนหาข้อมูลที่จะคัดลอกในแต่ละ Sheet
myNum = "A"
'ชื่อคอลัมน์ที่เป็นเงื่อนไข ถ้าคอลัมน์นี้มีข้อมูล จึงจะคัดลอก
myColName = "D"
' ระบุชื่อแผ่นงาน ที่จะเอาข้อมูลไปรวมกัน
summarySheet = "สรุป"
' ระบุแถวแรก ที่จะวางข้อมูล
LCopyToRow = 2
' *** ห้ามแก้ไขตั้งแต่บรรทัดนี้ เป็นต้นไป ***
Application.ScreenUpdating = False
Sheets(summarySheet).Select
Cells.Select
Selection.ClearContents
totalSheets = 0
For i = 1 To UBound(sheetArray)
If sheetArray(i) <> "" Then totalSheets = totalSheets + 1
Next i
i = 1
Do While i <= totalSheets
LSearchRow = myfirstRowToCopy
Sheets(sheetArray(i)).Select
While Len(Range(myNum & CStr(LSearchRow)).Value) > 0
If Range(myColName & CStr(LSearchRow)).Value >= 1 Then
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
Sheets(summarySheet).Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = LCopyToRow + 1
Sheets(sheetArray(i)).Select
End If
LSearchRow = LSearchRow + 1
Wend
i = i + 1
Loop
Application.CutCopyMode = False
Sheets(summarySheet).Select
Range("A1").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox Error(Err)
End Sub
วิธีเอาโค้ดไปใส่
1. คัดลอกโค้ด
2. ไปที่หน้าทีต้องการรวมข้อมูล
3. กดปุ่ม Atl + F11 เพื่อเปิดหน้าจอ
4. ดับเบิ้ลคลิกที่ สมุดงานนี้
5. วางโค้ด
6. บันทึก
7. ปิดหน้าจอที่เขียนโค้ด
วิธีการใส่โค้ดที่ปุ่ม
1. ไปที่แท็บ แทรก - รูปร่าง
2. สร้างปุ่มสี่เหลี่ยม
3. คลิกขวาที่ปุ่ม
4. เลือก กำหนดแมโคร
5. เลือก แก้ไข
6. จะเห็นชื่อแมโคร สมุดงานนี้.summary ให้คลิกเลือก
7. คลิก ตกลง
เป็นอันเสร็จการใส่โค้ดที่ปุ่ม
ลองใช้ดูนะครับ ถ้าไม่ต้องการสร้างเอง ก็ปรับใช้จากตัวอย่างได้เลย
ดาวน์โหลดไฟล์ Excel มาศึกษาดูก่อน คลิกที่นี่ (ไฟล์ Excel 2007/2010)
สมมุติว่า มีข้อมูลอยู่ 2 แผ่นงาน ให้ผู้ใช้เลือก เมื่อเลือกเสร็จแล้ว ให้ไปที่แผ่นงานสุดท้าย และคลิกปุ่มรวมข้อมูลที่เลือก โปรแกรม จะไปรวมข้อมูลที่เลือกจากทุกแผ่นงาน มาแสดงไว้ที่แผ่นงานสุดท้าย
แผ่นงานแรก ชื่อ หมวดที่ 1 มีรูปแบบดังนี้
ผู้ใช้เลือกรายการที่ 3 และรายการที่ 8
แผ่นงานที่ 2 ชื่อ หมวดที่2 มีรูปแบบและข้อมูลดังนี้
ผู้ใช้เลือกรายการที่ 2, 4, 7 และรายการที่ 9
ไปที่หน้า สุดท้าย แผ่นงาน สรุป และเมื่อกดปุ่ม จะได้ข้อมูล ดังนี้
จะเห็นว่า ในหน้านี้ นำข้อมูลเฉพาะที่ผู้ใช้เลือก ในแผ่นงาน หมวดที่ 1 และ หมวดที่ 2 มาไว้ที่นี่
ถ้าต้องการแก้ไข หรือดูโค้ด ให้คลิกขวาที่ปุ่ม และเลือก กำหนดแมโคร และคลิกแก้ไข
โค้ดที่เขียนที่ปุ่ม มีดังต่อไปนี้
Sub summary()
' จากเว็บ http://www.thongjoon.com หรือ http://tjkh.blogspot.com
' โดย ทองจุล ขันขาว
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim sheetArray(1 To 100)
Dim i As Integer
Dim totalSheets As Integer
Dim myfirstRowToCopy As Integer
Dim myNum as String
Dim myColName as String
Dim summarySheet as String
On Error GoTo Err_Execute
' ระบุชื่อ sheet ที่มีข้อมูล ที่จะนำไปรวมกันใน sheet สุดท้าย เพิ่มได้ถึง 100 sheets
sheetArray(1) = "หมวดที่1"
sheetArray(2) = "หมวดที่2"
'sheetArray(3) = "....."
'sheetArray(4) = "....."
'ระบุตำแหน่งข้อมูลแถวแรกที่ต้องการให้คัดลอก
myfirstRowToCopy = 2
'ชื่อคอลัมน์ที่มีข้อมูล ใช้สำหรับวนหาข้อมูลที่จะคัดลอกในแต่ละ Sheet
myNum = "A"
'ชื่อคอลัมน์ที่เป็นเงื่อนไข ถ้าคอลัมน์นี้มีข้อมูล จึงจะคัดลอก
myColName = "D"
' ระบุชื่อแผ่นงาน ที่จะเอาข้อมูลไปรวมกัน
summarySheet = "สรุป"
' ระบุแถวแรก ที่จะวางข้อมูล
LCopyToRow = 2
' *** ห้ามแก้ไขตั้งแต่บรรทัดนี้ เป็นต้นไป ***
Application.ScreenUpdating = False
Sheets(summarySheet).Select
Cells.Select
Selection.ClearContents
totalSheets = 0
For i = 1 To UBound(sheetArray)
If sheetArray(i) <> "" Then totalSheets = totalSheets + 1
Next i
i = 1
Do While i <= totalSheets
LSearchRow = myfirstRowToCopy
Sheets(sheetArray(i)).Select
While Len(Range(myNum & CStr(LSearchRow)).Value) > 0
If Range(myColName & CStr(LSearchRow)).Value >= 1 Then
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
Sheets(summarySheet).Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = LCopyToRow + 1
Sheets(sheetArray(i)).Select
End If
LSearchRow = LSearchRow + 1
Wend
i = i + 1
Loop
Application.CutCopyMode = False
Sheets(summarySheet).Select
Range("A1").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox Error(Err)
End Sub
วิธีเอาโค้ดไปใส่
1. คัดลอกโค้ด
2. ไปที่หน้าทีต้องการรวมข้อมูล
3. กดปุ่ม Atl + F11 เพื่อเปิดหน้าจอ
4. ดับเบิ้ลคลิกที่ สมุดงานนี้
5. วางโค้ด
6. บันทึก
7. ปิดหน้าจอที่เขียนโค้ด
วิธีการใส่โค้ดที่ปุ่ม
1. ไปที่แท็บ แทรก - รูปร่าง
2. สร้างปุ่มสี่เหลี่ยม
3. คลิกขวาที่ปุ่ม
4. เลือก กำหนดแมโคร
5. เลือก แก้ไข
6. จะเห็นชื่อแมโคร สมุดงานนี้.summary ให้คลิกเลือก
7. คลิก ตกลง
เป็นอันเสร็จการใส่โค้ดที่ปุ่ม
ลองใช้ดูนะครับ ถ้าไม่ต้องการสร้างเอง ก็ปรับใช้จากตัวอย่างได้เลย
ความคิดเห็น
แสดงความคิดเห็น