วันพฤหัสบดีที่ 30 มิถุนายน พ.ศ. 2554

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

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

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

ไม่มีความคิดเห็น:

แสดงความคิดเห็น