การคัดลอกข้อมูล จากหลายแผ่นงาน (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. คลิก ตกลง

เป็นอันเสร็จการใส่โค้ดที่ปุ่ม

ลองใช้ดูนะครับ ถ้าไม่ต้องการสร้างเอง ก็ปรับใช้จากตัวอย่างได้เลย

ความคิดเห็น

โพสต์ยอดนิยมจากบล็อกนี้

อุปมา อุปไมย สำนวนการเปรียบเทียบ ของไทย

แนวข้อสอบ เงื่อนไขสัญลักษณ์

เทคนิคการทำ ข้อสอบ อนุกรม ของ ก.พ.