นำข้อมูล sheet1 และ sheet2 รวมกันที่ sheet3

[niwat2811]

นำข้อมูล sheet1 และ sheet2 รวมกันที่ sheet3 โดยที่จำนวน Row ไม่เท่ากัน
รบกวนท่านอาจารย์ช่วยแนะนำเป็นสูตร หรือ Macro ก็ได้ครับ

[snasui]

การนำแต่ละชีทมาต่อกันสามารถดูได้จากที่นี่ครับ http://snasui.blogspot.com/2009/12/sheet-sheet.html จากนั้นค่อยนำไปประยุกต์ต่อ โดยทำชีทรวมไว้หนึ่งชีทต่างหาก จากนั้น Copy ไปวางเป็นค่าในอีกชีทแล้วค่อยจัดกลุ่ม แล้วทำ Subtotal และแทรกบรรทัดว่าง

สำหรับการใช้ VBA ควรเขียนมาก่อนครับ ติดตรงไหนค่อยมาดูกันต่อครับ

[niwat2811]

ลองใช้ macro แล้วแต่ก็ยังไม่ตรงกับความต้องการครับ รบกวนช่วยดูให้หน่อยนะครับ

[snasui]

ลองนำ Code ด้านล่างนี้ไป Run ดูตามลำดับผมตั้งชื่อให้สื่อความหมายว่าแต่ละ Procedure ใช้ทำงานใดครับ ก่อน Run ให้แทรกชีทชื่อ Sheet4 มาก่อนครับ

Code: Select all

Sub CollectData()
Dim ws As Worksheet
Dim r As Range
Dim rTarget As Range
For Each ws In Worksheets
    If ws.Name = "Sheet4" Then Exit Sub
    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
Next ws
Application.CutCopyMode = False
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 i As Byte, rInsert As Range
Dim lng As Long
With Sheets("Sheet4")
    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 & ")"
            r.Offset(-2, -3).Formula = "=sum(" & r.Offset(-3, -3).Address & ":" & _
                r.Offset(-3, -3).End(xlUp).Address & ")"
            r.Offset(-2, -2).Formula = "=sum(" & r.Offset(-3, -2).Address & ":" & _
                r.Offset(-3, -2).End(xlUp).Address & ")"
            r.Offset(-2, -1).Formula = "=sum(" & r.Offset(-3, -1).Address & ":" & _
                r.Offset(-3, -1).End(xlUp).Address & ")"
        Next r
   rInsert.ClearContents
End With
End Sub

[niwat2811]

เกือบตรงกับความต้องการแล้วครับ รบกวนอาจารย์ช่วยดูให้อีกนิดครับในขั้นตอนขั้นสุดท้ายตอน Insert Row ที่ Sheet4 ครับ ขอบพระคุณมากเลยครับ

[snasui]

ผมทดสอบ Run Code แล้วก็ได้ผลตามที่ต้องการ ดูตามภาพด้านล่างครับ

หากต้องการเพิ่มตารางลองทำเองก่อนครับ ติดตรงไหนก็มาถามกันต่อ

[niwat2811]

ขอบพระคุณอาจารย์มาก ๆ เลยครับ