การทำ Subtotal ด้วย Macro

[วังวู ช่ง]

ปัญหาที่จะปรึกษาก่อคืว่า ตัวเลกใน Column F ของ Sheet1 มีกานเปี่ยนแปงทุกปีครับ ความต้องกานก่อคื เมื่อ Run Macro ใน Sheet1 จะได้ข้อมูนลายงานเหมือนใน Sheet2

[snasui]

การทำเช่นนั้นสามารถทำได้โดยไม่ต้องใช้ Macro ครับ

ใน Sheet1 มีวิธีการคือ

1. เซลล์ A6 คีย์
   =COUNTIF(F$6:F6,F6)
   Enter > Copy ลงด้านล่าง
2. คลิกเซลล์ A5 > เข้าเมนู Data > Subtotal
3. เลือกตามภาพด้านล่าง

ดูไฟล์แนบประกอบครับ

[วังวู ช่ง]

ขอบคุนมากครับ ท่าน อาจาน ครับ ท่าน แนะนำวิทีดั่งก่าวนั้น เป็นบดเรียนแก่ผมไม่น้อย แต่เมื่อตัวเลกใน Column F มีกานเปรี่ยนแปงจำต้องไปที่ F6>Sort smallest to largest ค่อยมาทำตามวิทีดั่งก่าวเห็นว่าลำบากไม่น้อยครับ มีวิทีอื่นเรวกว่าไม่ หลื จะใช้ Macro ดีกว่า ช่วยด้วยครับ หลื ถ้าเลาใช้
Sub Macro1()
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:L671")
.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:A671"), Type:=xlFillDefault
Range("A6:A671").Select
Range("A5").Select
Selection.Subtotal GroupBy:=6, Function:=xlCount, TotalList:=Array(6), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

ก่อไ้ด้ แต่จะมีบันหาเวลาที่จำนวนพนมีกานเปรี่ยนแปงคื ออก หลื เข้าใหม่

[snasui]

ลองปรับ Code เป็นตามด้านล่างครับ

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 ช่วยปรับให้แสดงเป็น Code โดยดูตัวอย่างจากกระทู้นี้ครับ viewtopic.php?f=3&t=1187

[วังวู ช่ง]

เรียน ท่านอาจารย์ ที่เคาลบ และ ท่าน ผู้รู้ ที่นับถืครับ ก่อนอื่นต้องขอขอบคุน ท่าน อาจารย์ Snasui ที่ให้บดเรียนแก่ผมอย่างมากครับ.
บันหาวันนี้คื ต้องกานเมื่อ Run Macro ใน Sheet1 จะได้ผนดั่ง Sheet3 มีวิทีทำย่างไง ช่วยด้วยครับ (Column F มีกานเปรี่ยนแปงทุกปีคื ต้องได้ย้ายที่สอน หลื ที่ทำงานทุกปี) มีตัวย่างแนบมาด้วยครับ ขอบคุนมากครับ

(ไม่เก่งกานเขียน VBE เพียงใช้กานบันทึก Macro เท่านั้นครับ)

[snasui]

เพิ่ม Sheet4 เข้ามาอีก 1 ชีท จากนั้นใช้ Code ตามด้านล่างครับ

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

[วังวู ช่ง]

เรียน ท่านอาจารย์ ที่เคาลบครับ ท่าน ช่วยผมได้มากจิงๆ ก่อนอื่นหมด ผมต้องขอขอบคุนมาก และยอมรับว่าท่าน อาจารย์ เก่งมาก เก่งจิงๆ เพราะผมได้นั่งที่หน้าคอมพีวเตีมานานกว่าหนึ่งปีที่มารับตำแหน่งนี้ แต่ชอกคำตอบไม่พบ จนผมได้ตัดสินใจเข้ามาในประเทดไท มาชื้ตำลาเรียนมากเหลั้มทีเดียวเชั่น รวมสูตร & ฟังก์ชั่น และ Macro & VBA ของ ดวงพร เกี๋ยงคำ ราคายู่ที่ 259 บาด, เจาะลึก Excel สุดยอดเทคนิค การสร้าง Macro และการเขียน VBA ของ วิศัลย์ พัวรุ่งโรจน์ ราคายู่ที่ 179 บาด, เจาะลึก Excel เทคนิคการเขียนโปรแกรม VBA กับการประยุกต็ใช้งาน ของ วิศัลย์ พัวรุ่งโรจน์ ราคายู่ที่ 179 บาด ๆลๆ หลายเหลั้ม แต่ไม่พบคำตอบ

ขอบคุน ท่าน อาจารย์ มากครับ ขอให้โชกดี