การรวมข้อมูลจากหลายชีทด้วย VBA

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

ภาพแสดงข้อมูลต้นแหล่งและลักษณะข้อมูลเป้าหมายที่ต้องการ

เราสามารถใช้ VBA ในการดำเนินการดังกล่าว โดยเขียน 3 Procedure แยกหน้าที่กันดังนี้

1. CollectData เพื่อนำข้อมูลจากแต่ละชีทมาวางต่อกันใน Sheet4 และใช้เป็น Procedure ในการ Run Code
2. SortData เพื่อจัดเรียงข้อมูลใหม่ตามคอลัมน์ D (ชื่อประเภท) เป็น Sub Procedure ถูกเรียกใช้จากข้อ 1
3. 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

 

ตามแสดงตัวอย่างการใช้งาน