Snasui Excel Forum

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

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

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

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