Snasui Excel Forum

Code: Select all

Sub seachdara()
Dim ws As Worksheet
Dim lastrow As Long
Dim count As Integer

lastrow = Sheets("ก1").Cells(Rows.count, 1).End(xlUp).Row
Sheet6.Range("B6:Q200").ClearContents
count = 0
Dim p As Long
p = 5
For x = 1 To lastrow
    If Sheets("ก1").Cells(x, 1) = Sheet6.Range("A4") Then
        Sheet6.Cells(p, 2) = Sheets("ก1").Cells(x, 1)
        Sheet6.Cells(p, 3) = Sheets("ก1").Cells(x, 2)
        Sheet6.Cells(p, 4) = Sheets("ก1").Cells(x, 3)
        Sheet6.Cells(p, 5) = Sheets("ก1").Cells(x, 4)
        Sheet6.Cells(p, 6) = Sheets("ก1").Cells(x, 5)
        Sheet6.Cells(p, 7) = Sheets("ก1").Cells(x, 6)
        p = p + 1
        count = count + 1
  End If
  If Sheets("ก1").Cells(x, 1 + 1) = Sheet6.Range("A4") Then
        Sheet6.Cells(p, 2) = Sheets("ก1").Cells(x, 1)
        Sheet6.Cells(p, 3) = Sheets("ก1").Cells(x, 2)
        Sheet6.Cells(p, 4) = Sheets("ก1").Cells(x, 3)
        Sheet6.Cells(p, 5) = Sheets("ก1").Cells(x, 4)
        Sheet6.Cells(p, 6) = Sheets("ก1").Cells(x, 5)
        Sheet6.Cells(p, 7) = Sheets("ก1").Cells(x, 6)
        p = p + 1
        count = count + 1
  End If
    Next x
End Sub

Code: Select all

Sub test()
Dim wsResult As Worksheet, ws As Worksheet, l As Long, _
    r1 As Range, r2 As Range, r3 As Range, _
    rRow As Range, rCol As Range, rColHead As Range
    Set wsResult = ActiveSheet
    Set rColHead = wsResult.Range("b4:q4")
    
    wsResult.Range("b5:q2000").ClearContents
    l = 5
    
    '~~> เริ่มลูปแต่ละชีท
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "ก*" Then
            Set rRow = ws.Range("a2", ws.Range("a" & Rows.count).End(xlUp))
            Set rCol = ws.Range("b1", ws.Range("aa1").End(xlToLeft))
            '~~> เริ่มลูปแต่ละแถว
            For Each r1 In rRow
                If r1.Value = wsResult.Range("a4").Value Then
                    '~~>หากเจอวันที่ตรงก็เช็คว่าคอลัมน์อะไร
                    For Each r2 In rCol
                        For Each r3 In rColHead
                            If r2.Value = r3.Value Then
                                wsResult.Cells(l, r3.Column).Value = _
                                    ws.Cells(r1.Row, r2.Column).Value
                                Exit For
                            End If
                        Next r3
                    Next r2
                    l = l + 1
                End If
            Next r1
        End If
    Next ws
End Sub