Lookup วันที่

[snasui]

ลองตามด้านล่างครับ โดยให้ทำการ Assign Macro ClickCal ให้กับปุ่ม คำนวณปกติ และ Assign Macro ClickOT ให้กับปุ่ม คำนวณ OT

Code: Select all

Dim calType As String

Sub PasteWithDifSize()
    Dim c%, i%, j%, k%, s%, sCount%, strNameSheet$
    Dim rrAll As Range, rcAll As Range, rp As Range
    Dim r As Range, r1 As Range
    Dim rAll As Range, rt As Range, rSource As Range
    Sheets("Rev").Range("E6:E41").EntireRow.Hidden = False
    strNameSheet = InputBox("Please enter sheet name.")
    If strNameSheet = "" Then
        Exit Sub
    End If
    For s = 1 To Worksheets.Count
        If UCase(Worksheets(s).Name) = UCase(strNameSheet) Then
           sCount = sCount + 1
        End If
    Next s
    If sCount = 0 Then
          MsgBox "Sheet name is incorrect. Please try again."
          Exit Sub
    End If
    Sheets("Rev").Range("A6:A41,B6:B41,E6:R41").ClearContents
    With Sheets(strNameSheet)
        Set rcAll = .Range("B6", .Range("B" & Rows.Count).End(xlUp))
        Set rSource = .Range("B6", .Range("C" & Rows.Count).End(xlUp))
    End With
    With Sheets("Rev")
        For Each r In rcAll
             If .Range("E6") = "" Then
                 Set rp = .Range("E6").Resize(2, 10)
             Else
                 Set rp = .Range("E41").End(xlUp).Offset(1, 0).Resize(2, 10)
            End If
            i = 0: j = 0: c = 0
            If r.Offset(0, -1) <> "" Then
                rp.Cells(1, 0).Offset(0, -3) = r
                If calType = "Normal" Then
                    Set rrAll = r.Offset(0, 4).Resize(1, 31)
                Else
                    Set rrAll = r.Offset(1, 4).Resize(1, 31)
                End If
                For Each r1 In rrAll
                    i = i + 1
                    If calType = "Normal" Then
                        Select Case r1
                            Case "ชบ", "ชด", "บ", "ด"
                                c = c + 1
                                j = Int((c - 1) / 10) + 1
                                k = (c - 1) Mod 10 + 1
                                rp.Cells(j, k) = i
                        End Select
                    Else
                        Select Case r1
                            Case "ช", "บ", "ด", "ชบ", "ชด", "BD", "BDบ", "BDด"
                                c = c + 1
                                j = Int((c - 1) / 10) + 1
                                k = (c - 1) Mod 10 + 1
                                rp.Cells(j, k) = i
                        End Select
                    End If
                Next r1
                rp.Cells(1, 1).Offset(0, 10) = c
                rp.Cells(1, 1).Offset(0, 11) = "=RC[-1]*RC[-12]"
                rp.Cells(1, 1).Offset(0, 13) = "=RC[-3]*RC[-14]"
            End If
        Next r
        With .Range("M2")
            .Value = 1 & strNameSheet & Year(Date)
            .NumberFormat = "mmmm"
        End With
        For Each r In .Range("E6:E41")
            If r = "" Then
                r.EntireRow.Hidden = True
            End If
        Next r
        Set rAll = .Range("A6", .Range("A" & Rows.Count).End(xlUp)) _
              .SpecialCells(xlCellTypeConstants, 2)
        For Each rt In rAll
             rt.Offset(0, 1) = Application.VLookup(rt, rSource, 2, 0)
        Next rt
    End With
End Sub

Sub ClickCal()
    calType = "Normal"
    Call PasteWithDifSize
End Sub

Sub ClickOT()
    calType = "OT"
    Call PasteWithDifSize
End Sub

[joo]

ขอบคุณครับท่านอาจารย์ ผมเพิ่มกลับมาจากต่างจังหวัด วันนี้ได้ทดสอบโค๊ดที่อาจารย์ได้แนะนำไว้สามารถทำงานได้ตรงตามที่ต้องการเลยครับ
สอบถามเพิ่มนะครับในกรณีที่เราคลิกเลือก คำนวณ OT ที่ซีท Rev ต้องการให้ข้อมูลวันที่ที่ทำ OT คือ “ชบ,ชด” ,”ช,บ,ด ,BD”, “BDบ,BDด”แยกกันอยู่คนละบรรทัด
ตัวอย่างเช่น OT ของนายกำพล ที่ซีท Rev จากเดิมที่ E6:N6 ข้อมูลวันที่จะอยู่ที่บรรทัดเดียวคือ 7,13,21,27,28 ต้องการแยกให้เป็น 3 บรรทัดคือ
เซลล์ E6:N6 ข้อมูล OT “ชบ,ชด”ค่าที่แสดงก็จะเป็น 13
เซลล์ E7:N7 ข้อมูล OT “ช,บ,ด ,BD “ ค่าที่แสดงก็จะเป็น 7,27,28
เซลล์ E8:N8 ข้อมูล OT “BDบ,BDด “ ค่าที่แสดงก็จะเป็น 21
ผมลองปรับโค๊ดที่บรรทัดนี้แบบนี้ครับค่าที่ได้เหมือนเดิมครับไม่ยอมแยกให้ครับ ต้องปรับโค๊ดบรรดทัดไหนเพิ่มอย่างไรดีครับ

Code: Select all

Select Case r1
                        'Case "ช", "บ", "ด", "ชบ", "ชด", "BD", "BDช", "BDบ"
                            Case "ช", "บ", "ด", "BD"
                               c = c + 1
                                j = Int((c - 1) / 10) + 1
                                k = (c - 1) Mod 10 + 1
                              rp.Cells(j, k) = i
                         Select Case r1t
                       Case "ชบ", "ชด"
                              c = c + 1
                              j = Int((c - 1) / 10) + 1
                               k = (c - 1) Mod 10 + 1
                               rp.Cells(j, k) = i
                           Select Case r1s
                          Case "BDช", "BDบ"
                             c = c + 1
                              j = Int((c - 1) / 10) + 1
                              k = (c - 1) Mod 10 + 1
                             rp.Cells(j, k) = i
                        End Select
                    End If
                Next r1

[snasui]

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

Code: Select all

Option Explicit

Dim calType As String

Sub PasteWithDifSize()
    Dim c%, d%, e%, i%, j%, k%, s%, sCount%, strNameSheet$
    Dim rrAll As Range, rcAll As Range, rp As Range
    Dim r As Range, r1 As Range
    Dim rAll As Range, rt As Range, rSource As Range
    Sheets("Rev").Range("E6:E41").EntireRow.Hidden = False
    strNameSheet = InputBox("Please enter sheet name.")
    If strNameSheet = "" Then
        Exit Sub
    End If
    For s = 1 To Worksheets.Count
        If UCase(Worksheets(s).Name) = UCase(strNameSheet) Then
           sCount = sCount + 1
        End If
    Next s
    If sCount = 0 Then
          MsgBox "Sheet name is incorrect. Please try again."
          Exit Sub
    End If
    Sheets("Rev").Range("A6:A41,B6:B41,E6:R41").ClearContents
    With Sheets(strNameSheet)
        Set rcAll = .Range("B6", .Range("B" & Rows.Count).End(xlUp))
        Set rSource = .Range("B6", .Range("C" & Rows.Count).End(xlUp))
    End With
    With Sheets("Rev")
        For Each r In rcAll
             If .Range("E6") = "" Then
                 Set rp = .Range("E6").Resize(2, 10)
             Else
                 Set rp = .Range("E41").End(xlUp).Offset(1, 0).Resize(2, 10)
            End If
            i = 0: j = 0: c = 0: d = 0: e = 0
            If r.Offset(0, -1) <> "" Then
                rp.Cells(1, 0).Offset(0, -3) = r
                If calType = "Normal" Then
                    Set rrAll = r.Offset(0, 4).Resize(1, 31)
                Else
                    Set rrAll = r.Offset(1, 4).Resize(1, 31)
                End If
                For Each r1 In rrAll
                    i = i + 1
                    If calType = "Normal" Then
                        Select Case r1
                            Case "ชบ", "ชด", "บ", "ด"
                                c = c + 1
                                j = Int((c - 1) / 10) + 1
                                k = (c - 1) Mod 10 + 1
                                rp.Cells(j, k) = i
                        End Select
                    Else
                        Select Case r1
                            Case "ช", "บ", "ด", "BD"
                                c = c + 1
                                j = Int((c - 1) / 10) + 1
                                k = (c - 1) Mod 10 + 1
                                rp.Cells(j, k) = i
                            Case "ชบ", "ชด"
                                d = d + 1
                                j = Int((d - 1) / 10) + 1
                                k = (d - 1) Mod 10 + 1
                                rp.Cells(j + 1, k) = i
                            Case "BDด", "BDบ"
                                e = e + 1
                                j = Int((e - 1) / 10) + 1
                                k = (e - 1) Mod 10 + 1
                                rp.Cells(j + 2, k) = i
                        End Select
                    End If
                Next r1
                rp.Cells(1, 1).Offset(0, 10) = c
                rp.Cells(1, 1).Offset(0, 11) = "=RC[-1]*RC[-12]"
                rp.Cells(1, 1).Offset(0, 13) = "=RC[-3]*RC[-14]"
            End If
        Next r
        With .Range("M2")
            .Value = 1 & strNameSheet & Year(Date)
            .NumberFormat = "mmmm"
        End With
        For Each r In .Range("E6:E41")
            If r = "" Then
                r.EntireRow.Hidden = True
            End If
        Next r
        Set rAll = .Range("A6", .Range("A" & Rows.Count).End(xlUp)) _
              .SpecialCells(xlCellTypeConstants, 2)
        For Each rt In rAll
             rt.Offset(0, 1) = Application.VLookup(rt, rSource, 2, 0)
        Next rt
    End With
End Sub

Sub ClickCal()
    calType = "Normal"
    Call PasteWithDifSize
End Sub

Sub ClickOT()
    calType = "OT"
    Call PasteWithDifSize
End Sub

[joo]

ขอบคุณครับอาจารย์... สามารถใช้งานได้ตามที่ต้องการแล้วครับ ผมปรับแก้ไขโค๊ดที่บรรดทัดนี้ใหม่เนื่องจากวันที่ที่แสดงไม่ตรงครับ

Code: Select all

If calType = "Normal" Then
                    Set rrAll = r.Offset(0, 4).Resize(1, 31)
                Else
                    Set rrAll = r.Offset(1, 4).Resize(1, 31)
                End If

ปรับแก้เป็น

Code: Select all

If calType = "Normal" Then
                    Set rrAll = r.Offset(0, 3).Resize(1, 31)
                Else
                    Set rrAll = r.Offset(1, 3).Resize(1, 31)
                End If