กรณีต้องการรวมข้อมูลจากหลายชีทโดยนำข้อมูลมาต่อกันด้วยสูตรนั้นสามารถศึกษาได้จาก การนำข้อมูลจากหลาย Sheet มาต่อกันใน Sheet เดียว สำหรับที่จะนำเสนอต่อไปนี้เป็นนำข้อมูลจากหลายชีทมารวมในชีทเดียวกันด้วย VBA โดยทำการจัดเรียงใหม่และแทรกบรรทัดผลรวมของแต่ละชุดไว้ให้ด้วย ซึ่งข้อมูลต้นแหล่งและข้อมูลเป้าหมายมีลักษณะตามภาพด้านล่างครับ
ภาพแสดงข้อมูลต้นแหล่งและลักษณะข้อมูลเป้าหมายที่ต้องการ

เราสามารถใช้ VBA ในการดำเนินการดังกล่าว โดยเขียน 3 Procedure แยกหน้าที่กันดังนี้
- CollectData เพื่อนำข้อมูลจากแต่ละชีทมาวางต่อกันใน Sheet4 และใช้เป็น Procedure ในการ Run Code
- SortData เพื่อจัดเรียงข้อมูลใหม่ตามคอลัมน์ D (ชื่อประเภท) เป็น Sub Procedure ถูกเรียกใช้จากข้อ 1
- InsertRow เพื่อแทรกบรรทัด, สรุปยอดรวมและทำการจัด Format เป็น Sub Procedure ถูกเรียกใช้จากข้อ 1
ตัวอย่าง VBA Code
Option Explicit Sub CollectData() Dim ws As Worksheet Dim r As Range Dim rTarget As Range Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "Sheet4" Then With Sheets("Sheet4") Set rTarget = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) End With Set r = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp)) r.SpecialCells(xlCellTypeConstants).EntireRow.Copy rTarget.PasteSpecial xlPasteValues End If Next ws SortData InsertRow Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Sub SortData() Dim r As Range Dim rs As Range With Sheets("Sheet4") Set r = .Range("A1", .Range("H" & Rows.Count).End(xlUp)) Set rs = r.Cells(2, 1).Offset(0, 3).Resize(r.Count - 1, 1) .Sort.SortFields.Clear .Sort.SortFields.Add Key:=rs _ , SortOn:=xlSortOnValues, Order:=xlAscending, _ DataOption:=xlSortNormal With .Sort .SetRange r .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With End Sub Sub InsertRow() Dim r As Range, rAll As Range Dim rFmt As Range, rsHead As Range Dim rtHead As Range, rInsert As Range With Sheets("Sheet1") Set rFmt = .Range("A2") Set rsHead = .Range("A1:H1") End With With Sheets("Sheet4") Set rtHead = .Range("A1") Set rAll = .Range("D2", .Range("D" & Rows.Count).End(xlUp)) For Each r In rAll If r <> r.Offset(1, 0) Then r.Offset(1, 5) = True End If Next r Set rInsert = .Range("I:I").SpecialCells(xlCellTypeConstants) For Each r In rInsert r.Resize(2, 1).EntireRow.Insert shift:=xlShiftDown r.Offset(-2, -7) = "Total" r.Offset(-2, -4).Formula = "=sum(" & r.Offset(-3, -4).Address & ":" & _ r.Offset(-3, -4).End(xlUp).Address & ")" Set r = r.Offset(-2, -4) r = Application.ConvertFormula(r.FormulaR1C1, xlR1C1, xlA1, xlRelative) r.Resize(1, 4).FillRight rFmt.Copy r.CurrentRegion.PasteSpecial xlPasteFormats Next r .Range("I:I").Clear End With rsHead.Copy rtHead End Sub |
Revised: January 29, 2017 at 07:21
You must log in to post a comment.