ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลข้ามชีทตามเงื่อนไข

[9KiTTi]

ขออนุญาตขอข้อเสนอแนะช่วยปรับVBAในการคัดลอกข้อมูลข้ามชีทตามเงื่อนไขหน่อยครับ ผมต้องการคัดลอกข้อมูลจากชีทอื่นๆยกเว้นชื่อชื่อ data / OP / detail โดยที่คัดดลอกช่วงA7:D30 มาวางในชีทชื่อ detail โดยให้มาวางในช่องB3โดยที่มีเงื่อนไขว่าช่องA5ชีทที่คัดลอกช่วงA7:D3ต้องมีค่าเท่ากับข้อมูลในแถวที่1ของชีทdetail ตามโค๊ดที่ผมลองทำจะคัดลอกออกมาเรียงต่อไปกันแต่ไม่ตรงตามเงื่อนไข ขอคำแนะนำด้วยครับ ขอบพระคุณครับ

Code: Select all

Sub CopyDataToDetailSheet()
    Dim ws As Worksheet
    Dim detailSheet As Worksheet
    Dim lastCol As Long
    Dim copyRange As Range

    Set detailSheet = ThisWorkbook.Sheets("detail")
    
    lastCol = 2

    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "data" And ws.Name <> "OP" And ws.Name <> "detail" Then
            Set copyRange = ws.Range("A7:D30")

            copyRange.Copy Destination:=detailSheet.Cells(3, lastCol)

            lastCol = lastCol + copyRange.Columns.Count
        End If
    Next ws
    MsgBox "การคัดลอกข้อมูลเสร็จสมบูรณ์"
End Sub

[puriwutpokin]

ปรับตามนี้ดูครับ

Code: Select all

Sub CopyDataToDetailSheet()
    Dim ws As Worksheet
    Dim detailSheet As Worksheet
    Dim lastCol As Long
    Dim copyRange As Range
    On Error Resume Next
    Set detailSheet = ThisWorkbook.Sheets("detail")
    
    lastCol = 2

    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "data" And ws.Name <> "OP" And ws.Name <> "detail" Then
            Set copyRange = ws.Range("A7:D30")
             lastCol = Application.Match(ws.Range("A5"), detailSheet.Range("b1:bu1"), 0)
            copyRange.Copy Destination:=detailSheet.Cells(3, lastCol + 1)

            lastCol = lastCol * 4
        End If
    Next ws
    MsgBox "การคัดลอกข้อมูลเสร็จสมบูรณ์"
End Sub

[9KiTTi]

ปรับตามนี้ดูครับ

Code: Select all

Sub CopyDataToDetailSheet()
    Dim ws As Worksheet
    Dim detailSheet As Worksheet
    Dim lastCol As Long
    Dim copyRange As Range
    On Error Resume Next
    Set detailSheet = ThisWorkbook.Sheets("detail")
    
    lastCol = 2

    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "data" And ws.Name <> "OP" And ws.Name <> "detail" Then
            Set copyRange = ws.Range("A7:D30")
             lastCol = Application.Match(ws.Range("A5"), detailSheet.Range("b1:bu1"), 0)
            copyRange.Copy Destination:=detailSheet.Cells(3, lastCol + 1)

            lastCol = lastCol * 4
        End If
    Next ws
    MsgBox "การคัดลอกข้อมูลเสร็จสมบูรณ์"
End Sub

ขอบพระคุณครับ ใช้งานได้อย่างที่ต้องการครับ