สร้างโค๊ด VBA เพื่อรวมชีสแต่ว่าข้อมูลชีสจัดตำแหน่งไม่เป็นรูปแบบไม่เหมือนตารางหลัก

[SuminO]

สร้างโค๊ด VBA เพื่อรวมชีสแต่ว่าข้อมูลชีสจัดตำแหน่งไม่เป็นรูปแบบที่คล้ายกันกับตารางหลัก
เพื่อรวมทุกชีสมาไว้ในชีสเดียวกัน ชีส Main คือชีสหลัก โดยมีหัวข้อเก็บข้อมูลจาก A1:V1
แต่รูปแบบข้องชีสต่าง ๆ ไม่เหมือนกันต่างกันแค่ ภาค และจังหวัด
เช่นชีส ProductUpdate A1 คือหัวข้อ =ชื่อ A2 จะเป็นภาค และ A3 คือจังหวัด แล้วถัดลงมาจากจังหวัดก็คือรายชื่อที่ต้องการเก็บ

จะเป็นรูปแบบนี้ทุกชีส
ฉันจะเขียนสูตรยังไง เมื่อ A1:A100
มีคำว่า ภาคให้นำข้อมูลไปลงที่ ชีส Main A1

โค๊ดที่สร้างได้ข้อมูลยังไม่ตรงครับมันวนซ้ำหลายรอบ
ต้องปรับตรงไหน
รบกวนอาจารย์ด้วย
และขอบพระคุณล่วงหน้าครับ

Code: Select all

Sub ConsolidateSheets()
    Dim ws As Worksheet
    Dim mainWs As Worksheet
    Dim lastRow As Long
    Dim copyRow As Long
    Dim dataStartRow As Long

    Set mainWs = ThisWorkbook.Sheets("Main")

    mainWs.Range("A2:V100").ClearContents

    copyRow = 2

    For Each ws In ThisWorkbook.Worksheets

        If ws.Name <> mainWs.Name Then
     
            For i = 1 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                If ws.Cells(i, 1).Value Like "*ภาค*" Then
                                   dataStartRow = i + 2
                    
                                    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
                    ws.Range(ws.Cells(dataStartRow, 1), ws.Cells(lastRow, 22)).Copy
                    mainWs.Range("A" & copyRow).PasteSpecial Paste:=xlPasteValues
        
                    copyRow = mainWs.Cells(mainWs.Rows.Count, "A").End(xlUp).Row + 1
                End If
            Next i
        End If
    Next ws
    

    Application.CutCopyMode = False
    
 
End Sub

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Sub ConsolidateSheets()
    Dim ws As Worksheet, rall As Range, r As Range
    Dim mainWs As Worksheet, rg As String, pv As String, pd As String
    Dim i As Integer
    Dim arr(99999, 8) As Variant
    Set mainWs = ThisWorkbook.Sheets("Main")
    
    mainWs.Range("A2").CurrentRegion.Offset(1, 0).ClearContents
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> mainWs.Name Then
            With ws
                Set rall = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
                For Each r In rall
                    If InStr(r.Value, "ภาค") Then
                        rg = r.Value
                    ElseIf InStr(r.Value, "Product") Then
                        pd = r.Value
                    Else
                        pv = r.Value
                    End If
                    If r.Offset(0, 1).Value <> "" Then
                        arr(i, 0) = rg
                        arr(i, 1) = pv
                        arr(i, 2) = pd
                        arr(i, 3) = ws.Name
                        arr(i, 4) = r.Offset(0, 1).Value
                        arr(i, 5) = r.Offset(0, 2).Value
                        arr(i, 6) = r.Offset(0, 3).Value
                        arr(i, 7) = r.Offset(0, 4).Value
                        arr(i, 8) = r.Offset(0, 5).Value
                        i = i + 1
                    End If
                Next r
            End With
        End If
    Next ws
    With mainWs
        If i > 0 Then
            .Range("a2").Resize(i, UBound(arr, 2) + 1).Value = arr
        End If
    End With

End Sub