Snasui Excel Forum

Code: Select all

Sub Macro1()
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Row
    Range("A6").Select
    Selection.RemoveSubtotal
    Range("F6").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("F6"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A6:L" & LastRow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(R6C[5]:RC[5],RC[5])"
    Selection.AutoFill Destination:=Range("A6:A" & LastRow), Type:=xlFillDefault
    Range("A5").Select
    Selection.Subtotal GroupBy:=6, Function:=xlCount, TotalList:=Array(6), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

Code: Select all

Sub Macro1()
    Dim LastRow As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    LastRow = Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Row
    Sheets("Sheet4").Range("A5").RemoveSubtotal
    Sheets("Sheet4").Cells.Clear
    Sheets("Sheet1").Cells.Copy Sheets("Sheet4").Range("A1")
    Range("A6").Select
    Sheets("Sheet4").Select
    Range("G6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Selection.FormulaR1C1 = "=VLOOKUP(RC[-1],name,2)"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("K6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Selection.FormulaR1C1 = "=DATEDIF(RC[-1],TODAY(),""Y"")"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("F6").Select
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("F6"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range("A6:M" & LastRow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Selection.FormulaR1C1 = "=COUNTIF(R6C[5]:RC[5],RC[5])"
    
    Range("A6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Range("A5").Select
    Range(Selection, Selection.End(xlDown)).Offset(0, 1) _
        .SpecialCells(xlBlanks).EntireRow.Delete
    Selection.Subtotal GroupBy:=6, Function:=xlCount, TotalList:=Array(6), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    Range("A1:M1").Select
    Call FormatCells
    Sheets("Sheet4").Range("A5").ClearOutline
    Application.ScreenUpdating = True
End Sub
Sub FormatCells()
    Dim rAll As Range
    Dim r As Range
    With Sheets("Sheet4")
        Set rAll = .Range("B6", .Range("B" & Rows.Count).End(xlUp).Offset(2, 0)) _
            .SpecialCells(xlBlanks)
        .Range("F6", .Range("F6").End(xlDown)).Copy
        .Range("F6").PasteSpecial xlPasteValues
    End With
    For Each r In rAll
        If r.Offset(0, 3) <> "Grand Count" Then
            r.Offset(0, -1) = "ลวม " & r.Offset(-1, 4).Value
         Else
            r.Offset(0, -1) = r.Offset(0, 3).Value
        End If
        r.Offset(0, 3).ClearContents
        r.Offset(0, 4) = r.Offset(0, 4).Value & " ¤¹"
        r.Offset(0, -1).Resize(1, 5).HorizontalAlignment = xlCenterAcrossSelection
        r.Offset(0, -1).Resize(1, 5).Interior.Color = 5296274
        r.Offset(0, 4).Resize(1, 8).HorizontalAlignment = xlCenterAcrossSelection
        r.Offset(0, 4).Resize(1, 8).Interior.Color = 5296274
        r.Offset(0, -1).Resize(1, 12).Font.FontStyle = "Bold"
    Next r
    Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(-1, 0).Resize(2, 13) _
        .Borders.LineStyle = xlContinuous
End Sub