เขียนสูตร VBA เพื่อรวม Sheet ให้มารวมกันเหมือนตัวอย่าง

[SuminO]

เขียนสูตร VBA เพื่อรวม Sheet ให้มารวมกันเป็น ชีสเดียวแบบนี้
ผมลองดูแล้วมันมาไม่ครบครับ

Code: Select all

Sub MergeSheets()
    Dim mainSheet As Worksheet
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim targetRow As Long
    Dim i As Long

    On Error Resume Next
    Set mainSheet = ThisWorkbook.Worksheets("MainSheet")
    On Error GoTo 0
    If mainSheet Is Nothing Then
        Set mainSheet = ThisWorkbook.Worksheets.Add
        mainSheet.Name = "MainSheet"
    Else
       ' mainSheet.Cells.Clear
    End If
    
 
    mainSheet.Range("A1:R1").Value = Array("P/O No.", "Date", "CAPRE NO :", "Vendor Name", "Vendor Address", "Vendor Tell", "Credit Term:", "Refer P/R No :", "Dept.Order :", "Item", "Description", "Request Date", "Unit", "Qty", "Unit Price(Baht)", "Amount(Baht)", "Notes:1", "Notes:2", "Notes:3")
    

    targetRow = 3
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> mainSheet.Name Then
            lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
            For i = 18 To lastRow
                
                If ws.Cells(i, "D").Value <> "" Then
                    mainSheet.Cells(targetRow, "A").Resize(1, 15).Value = ws.Range("L9:M9,M4,D10:E12,L13:L14").Value
                    mainSheet.Cells(targetRow, "I").Value = ws.Cells(i, "D").Value
                    mainSheet.Cells(targetRow, "J").Value = ws.Cells(i, "E").Value
                    mainSheet.Cells(targetRow, "K").Value = ws.Cells(i, "I").Value
                    mainSheet.Cells(targetRow, "L").Value = ws.Cells(i, "J").Value
                    mainSheet.Cells(targetRow, "M").Value = ws.Cells(i, "K").Value
                    mainSheet.Cells(targetRow, "N").Value = ws.Cells(i, "L").Value
                    mainSheet.Cells(targetRow, "O").Value = ws.Cells(i, "M").Value
                    mainSheet.Cells(targetRow, "P").Value = ws.Cells(i, "E").Offset(54, 0).Value
                    mainSheet.Cells(targetRow, "Q").Value = ws.Cells(i, "E").Offset(55, 0).Value
                    mainSheet.Cells(targetRow, "R").Value = ws.Cells(i, "E").Offset(56, 0).Value
                    targetRow = targetRow + 1
                End If
            Next i
        End If
    Next ws
End Sub

[SuminO]

ปรับได้ประมาณนี้ครับ
แต่ว่า เมื่อ Loop เสร็จ ชีสแรก ไม่ไปหาชีสถัดไปครับ

Code: Select all

Sub MergeSheets()
    Dim mainSheet As Worksheet
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim targetRow As Long
    Dim i As Long
    Dim j As Long
    Dim cell As Range

    On Error Resume Next
    Set mainSheet = ThisWorkbook.Worksheets("MainSheet")
    On Error GoTo 0
    If mainSheet Is Nothing Then
        Set mainSheet = ThisWorkbook.Worksheets.Add
        mainSheet.Name = "MainSheet"
    Else
        mainSheet.Cells.Clear
    End If

    mainSheet.Range("A1:T1").Value = Array("ลำดับ", "P/O No.", "Date", "CAPRE NO :", "Shipping Name", "Vendor Name", "Vendor Address", "Vendor Tell", "Credit Term:", "Refer P/R No :", "Dept.Order :", "Item", "Description", "Request Date", "Unit", "Qty", "Unit Price(Baht)", "Amount(Baht)", "Notes:1", "Notes:2", "Notes:3")


    targetRow = 2 
    For i = 4 To ThisWorkbook.Worksheets.Count
        Set ws = ThisWorkbook.Worksheets(i)

        ' วนลูปข้อมูลในคอลัมน์ D18:D56
        For j = 18 To 56
            If ws.Cells(j, "D").Value <> "" Then
                ' เพิ่มข้อมูลจากชีตปัจจุบันไปยังชีตหลัก
                mainSheet.Cells(targetRow, "A").Value = ws.Name ' ลำดับ
                mainSheet.Cells(targetRow, "B").Value = ws.Range("M11").Value ' P/O No.
                mainSheet.Cells(targetRow, "C").Value = ws.Range("M9").Value ' Date
                mainSheet.Cells(targetRow, "D").Value = ws.Range("M4").Value ' CAPRE NO :
                mainSheet.Cells(targetRow, "E").Value = ws.Range("D10").Value ' Shipping Name
                mainSheet.Cells(targetRow, "F").Value = ws.Range("D12").Value ' Vendor Name
                mainSheet.Cells(targetRow, "G").Value = ws.Range("D13").Value ' Vendor Address
                mainSheet.Cells(targetRow, "H").Value = ws.Range("D14").Value ' Vendor Tell
                mainSheet.Cells(targetRow, "I").Value = ws.Range("M11").Value ' Credit Term:
                mainSheet.Cells(targetRow, "J").Value = ws.Range("L13").Value ' Refer P/R No :
                mainSheet.Cells(targetRow, "K").Value = ws.Range("L14").Value ' Dept.Order :
                mainSheet.Cells(targetRow, "L").Value = ws.Cells(j, "D").Value ' Item
                mainSheet.Cells(targetRow, "M").Value = ws.Cells(j, "E").Value ' Description
                mainSheet.Cells(targetRow, "N").Value = ws.Cells(j, "I").Value ' Request Date
                mainSheet.Cells(targetRow, "O").Value = ws.Cells(j, "J").Value ' Unit
                mainSheet.Cells(targetRow, "P").Value = ws.Cells(j, "K").Value ' Qty
                mainSheet.Cells(targetRow, "Q").Value = ws.Cells(j, "L").Value ' Unit Price(Baht)
                mainSheet.Cells(targetRow, "R").Value = ws.Cells(j, "M").Value ' Amount(Baht)
                mainSheet.Cells(targetRow, "S").Value = ws.Range("E62").Value ' Notes:1
                mainSheet.Cells(targetRow, "T").Value = ws.Range("E63").Value ' Notes:2
                mainSheet.Cells(targetRow, "U").Value = ws.Range("E64").Value ' Notes:3
                targetRow = targetRow + 1
            End If
        Next j
    Next i
End Sub

[snasui]

ตัวอย่าง Code ตามด้านล่าง ลองไปปรับใช้ดูครับ

Code: Select all

Sub MergeSheets()
    Dim mainSheet As Worksheet
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim targetRow As Long
    Dim i As Long, l As Long
    Dim arr(99999, 20) As Variant

    On Error Resume Next
    Set mainSheet = ThisWorkbook.Worksheets("MainSheet")
    On Error GoTo 0
    If mainSheet Is Nothing Then
        Set mainSheet = ThisWorkbook.Worksheets.Add
        mainSheet.Name = "MainSheet"
    Else
       ' mainSheet.Cells.Clear
    End If
    
    targetRow = 3
    For Each ws In ThisWorkbook.Worksheets
        If ws.Index > 1 And ws.Name <> mainSheet.Name Then
            lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
            For i = 18 To lastRow
                If ws.Cells(i, "D").Value <> "" And IsNumeric(ws.Cells(i, "D").Value) Then
                    arr(l, 0) = VBA.Right(ws.Cells(9, "L").Value, 4)
                    arr(l, 1) = ws.Cells(9, "L").Value
                    arr(l, 2) = ws.Cells(9, "M").Value
                    arr(l, 3) = ws.Cells(4, "M").Value
                    arr(l, 4) = ws.Cells(8, "D").Value
                    arr(l, 5) = ws.Cells(10, "D").Value
                    arr(l, 6) = ws.Cells(11, "E").Value
                    arr(l, 7) = ws.Cells(12, "E").Value
                    arr(l, 8) = ws.Cells(11, "M").Value
                    arr(l, 9) = ws.Cells(13, "L").Value
                    arr(l, 10) = ws.Cells(14, "D").Value
                    arr(l, 11) = ws.Cells(i, "D").Value
                    arr(l, 12) = ws.Cells(i, "E").Value
                    arr(l, 13) = ws.Cells(i, "I").Value
                    arr(l, 14) = ws.Cells(i, "J").Value
                    arr(l, 15) = ws.Cells(i, "K").Value
                    arr(l, 16) = ws.Cells(i, "L").Value
                    arr(l, 17) = ws.Cells(i, "M").Value
                    arr(l, 18) = ws.Cells(62, "E").Value
                    arr(l, 19) = ws.Cells(63, "E").Value
                    arr(l, 20) = ws.Cells(64, "E").Value
                    targetRow = targetRow + 1
                    l = l + 1
                End If
            Next i
        End If
    Next ws
    If l > 0 Then
        With mainSheet
            .Cells.ClearContents
            .Range("A1:U1").Value = Array("ลำดับ", "P/O No.", "Date", "CAPRE NO :", _
                "Shipping Name", "Vendor Name", "Vendor Address", "Vendor Tell", _
                "Credit Term:", "Refer P/R No :", "Dept.Order : ", "Item ", "Description", _
                "Request Date", "Unit", "Qty", "Unit Price(Baht)", "Amount(Baht)", "Notes:1", "Notes:2", "Notes:3")
            .Range("a2").Resize(l, UBound(arr, 2) + 1) = arr
        End With
    End If
End Sub