Snasui Excel Forum

Posted: **Wed Dec 21, 2011 11:06 am**

สวัสดีครับท่านอาจารย์ คือว่าได้ลองประยุกต์ Code ของท่านอาจารย์ แล้วได้นำมาใช้กับงานก็ตรงกับความต้องการ แต่อยากจะรบกวนถามท่านอาจารย์ว่าถ้าเราจะรวม Code ตามตัวอย่างด้านล่าง โดยให้ทำงานครั้งเดียวจะได้ไหมครับและ Code ที่ว่านี้สามารถปรับให้กระชับลงกว่านี้ได้ไหม(ตรงขั้นตอนรวมทีละคอลัมภน์ที่ Sub InsertRow ครับ)

Code: Select all

Sub SortData()
Dim r As Range
Dim rs As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
    Set r = .Range("A7", .Range("X" & Rows.Count).End(xlUp))
    Set rs = r.Cells(2, 1).Offset(0, 2).Resize(r.Count - 1, 1)
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rs _
    , SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlsortnarmal
With .Sort
    .SetRange r
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End With
Range("X8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A1:X1").Select
    Application.ScreenUpdating = True
End Sub

Sub InsertRow()
Dim r As Range, rAll As Range
Dim i As Byte, rInsert As Range
Dim lng As Long
Application.ScreenUpdating = False
Range("A8").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("A8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False
With Sheets("Sheet1")
Set rAll = .Range("C8", .Range("C" & Rows.Count).End(xlUp))
For Each r In rAll
If r <> r.Offset(1, 0) Then
r.Offset(1, 22) = True
End If
Next r
Set rInsert = .Range("Y:Y").SpecialCells(xlCellTypeConstants)
For Each r In rInsert
r.Resize(2, 1).EntireRow.Insert shift:=xlShiftDown
r.Offset(-2, -22) = "รวม"
r.Offset(-2, -20).Formula = "=sum(" & r.Offset(-3, -20).Address & " : " & _
r.Offset(-3, -20).End(xlUp).Address & " ) "
r.Offset(-2, -19).Formula = "=sum(" & r.Offset(-3, -19).Address & " : " & _
r.Offset(-3, -19).End(xlUp).Address & " ) "
r.Offset(-2, -18).Formula = "=sum(" & r.Offset(-3, -18).Address & " : " & _
r.Offset(-3, -18).End(xlUp).Address & " ) "
r.Offset(-2, -17).Formula = "=sum(" & r.Offset(-3, -17).Address & " : " & _
r.Offset(-3, -17).End(xlUp).Address & " ) "
r.Offset(-2, -16).Formula = "=sum(" & r.Offset(-3, -16).Address & " : " & _
r.Offset(-3, -16).End(xlUp).Address & " ) "
r.Offset(-2, -15).Formula = "=sum(" & r.Offset(-3, -15).Address & " : " & _
r.Offset(-3, -15).End(xlUp).Address & " ) "
r.Offset(-2, -14).Formula = "=sum(" & r.Offset(-3, -14).Address & " : " & _
r.Offset(-3, -14).End(xlUp).Address & " ) "
r.Offset(-2, -13).Formula = "=sum(" & r.Offset(-3, -13).Address & " : " & _
r.Offset(-3, -13).End(xlUp).Address & " ) "
r.Offset(-2, -12).Formula = "=sum(" & r.Offset(-3, -12).Address & " : " & _
r.Offset(-3, -12).End(xlUp).Address & " ) "
r.Offset(-2, -11).Formula = "=sum(" & r.Offset(-3, -11).Address & " : " & _
r.Offset(-3, -11).End(xlUp).Address & " ) "
r.Offset(-2, -10).Formula = "=sum(" & r.Offset(-3, -10).Address & " : " & _
r.Offset(-3, -10).End(xlUp).Address & " ) "
r.Offset(-2, -9).Formula = "=sum(" & r.Offset(-3, -9).Address & " : " & _
r.Offset(-3, -9).End(xlUp).Address & " ) "
r.Offset(-2, -8).Formula = "=sum(" & r.Offset(-3, -8).Address & " : " & _
r.Offset(-3, -8).End(xlUp).Address & " ) "
r.Offset(-2, -7).Formula = "=sum(" & r.Offset(-3, -7).Address & " : " & _
r.Offset(-3, -7).End(xlUp).Address & " ) "
r.Offset(-2, -6).Formula = "=sum(" & r.Offset(-3, -6).Address & " : " & _
r.Offset(-3, -6).End(xlUp).Address & " ) "
r.Offset(-2, -5).Formula = "=sum(" & r.Offset(-3, -5).Address & " : " & _
r.Offset(-3, -5).End(xlUp).Address & " ) "
r.Offset(-2, -4).Formula = "=sum(" & r.Offset(-3, -4).Address & " : " & _
r.Offset(-3, -4).End(xlUp).Address & " ) "
r.Offset(-2, -3).Formula = "=sum(" & r.Offset(-3, -3).Address & " : " & _
r.Offset(-3, -3).End(xlUp).Address & " ) "
r.Offset(-2, -2).Formula = "=sum(" & r.Offset(-3, -2).Address & " : " & _
r.Offset(-3, -2).End(xlUp).Address & " ) "
Next r
rInsert.ClearContents
End With
Range("X25035").End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Sheets("Sheet3").Select
    Range("A1:X7").Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("A1:X1").Select
    ActiveSheet.Paste
    Application.ScreenUpdating = True
End Sub

Posted: **Wed Dec 21, 2011 11:15 am**

แนบไฟล์ตัวอย่างมาด้วยครับ จะได้สะดวกในการสังเกตการทำงานของ Code ครับ

Posted: **Wed Dec 21, 2011 11:56 am**

ครับผม ตัวอย่างไฟล์แนบครับท่านอาจารย์

Posted: **Wed Dec 21, 2011 2:07 pm**

ปลด Password ออกจาก Project ก่อนแล้วแนบมาอีกรอบครับ

Posted: **Wed Dec 21, 2011 3:44 pm**

ขอโทษด้วยครับอาจารย์ ไฟล์แนบใหม่นะครับ

Posted: **Wed Dec 21, 2011 5:05 pm**

กรณีต้องการรวม Code การ Sort และการ Insert เข้าด้วยกัน ใน Procedure ที่ชื่อ SortData ก่อนที่จะ Application.ScreenUpdating = True ให้แทรกคำว่า Call InsertRow เพื่อเป็นการเรียกใช้ Macro InsertRow ครับ ลองดูตัวอย่างตามด้านล่างครับ

Code: Select all

Sub SortData()
    Dim r As Range
    Dim rs As Range
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        Set r = .Range("A7", .Range("X" & Rows.Count).End(xlUp))
        Set rs = r.Cells(2, 1).Offset(0, 2).Resize(r.Count - 1, 1)
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=rs _
        , SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlsortnarmal
    With .Sort
        .SetRange r
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    End With
    Range("X8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Selection.Borders.LineStyle = xlContinuous
    Range("A1:X1").Select
    Call InsertRow
    Application.ScreenUpdating = True
End Sub

Sub InsertRow()
    Dim r As Range, rAll As Range
    Dim i As Byte, rInsert As Range
    Dim lng As Long
    Application.ScreenUpdating = False
    Range("A8").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Range("A8").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        ActiveSheet.Paste
        Application.CutCopyMode = False
    With Sheets("Sheet1")
    Set rAll = .Range("C8", .Range("C" & Rows.Count).End(xlUp))
        For Each r In rAll
            If r <> r.Offset(1, 0) Then
                r.Offset(1, 22) = True
            End If
        Next r
        Set rInsert = .Range("Y:Y").SpecialCells(xlCellTypeConstants)
        For Each r In rInsert
            r.Resize(2, 1).EntireRow.Insert shift:=xlShiftDown
            r.Offset(-2, -22) = "ÃÇÁ"
            r.Offset(-2, -20).Formula = "=sum(" & r.Offset(-3, -20).Address & " : " & _
            r.Offset(-3, -20).End(xlUp).Address & " ) "
            r.Offset(-2, -19).Formula = "=sum(" & r.Offset(-3, -19).Address & " : " & _
            r.Offset(-3, -19).End(xlUp).Address & " ) "
            r.Offset(-2, -18).Formula = "=sum(" & r.Offset(-3, -18).Address & " : " & _
            r.Offset(-3, -18).End(xlUp).Address & " ) "
            r.Offset(-2, -17).Formula = "=sum(" & r.Offset(-3, -17).Address & " : " & _
            r.Offset(-3, -17).End(xlUp).Address & " ) "
            r.Offset(-2, -16).Formula = "=sum(" & r.Offset(-3, -16).Address & " : " & _
            r.Offset(-3, -16).End(xlUp).Address & " ) "
            r.Offset(-2, -15).Formula = "=sum(" & r.Offset(-3, -15).Address & " : " & _
            r.Offset(-3, -15).End(xlUp).Address & " ) "
            r.Offset(-2, -14).Formula = "=sum(" & r.Offset(-3, -14).Address & " : " & _
            r.Offset(-3, -14).End(xlUp).Address & " ) "
            r.Offset(-2, -13).Formula = "=sum(" & r.Offset(-3, -13).Address & " : " & _
            r.Offset(-3, -13).End(xlUp).Address & " ) "
            r.Offset(-2, -12).Formula = "=sum(" & r.Offset(-3, -12).Address & " : " & _
            r.Offset(-3, -12).End(xlUp).Address & " ) "
            r.Offset(-2, -11).Formula = "=sum(" & r.Offset(-3, -11).Address & " : " & _
            r.Offset(-3, -11).End(xlUp).Address & " ) "
            r.Offset(-2, -10).Formula = "=sum(" & r.Offset(-3, -10).Address & " : " & _
            r.Offset(-3, -10).End(xlUp).Address & " ) "
            r.Offset(-2, -9).Formula = "=sum(" & r.Offset(-3, -9).Address & " : " & _
            r.Offset(-3, -9).End(xlUp).Address & " ) "
            r.Offset(-2, -8).Formula = "=sum(" & r.Offset(-3, -8).Address & " : " & _
            r.Offset(-3, -8).End(xlUp).Address & " ) "
            r.Offset(-2, -7).Formula = "=sum(" & r.Offset(-3, -7).Address & " : " & _
            r.Offset(-3, -7).End(xlUp).Address & " ) "
            r.Offset(-2, -6).Formula = "=sum(" & r.Offset(-3, -6).Address & " : " & _
            r.Offset(-3, -6).End(xlUp).Address & " ) "
            r.Offset(-2, -5).Formula = "=sum(" & r.Offset(-3, -5).Address & " : " & _
            r.Offset(-3, -5).End(xlUp).Address & " ) "
            r.Offset(-2, -4).Formula = "=sum(" & r.Offset(-3, -4).Address & " : " & _
            r.Offset(-3, -4).End(xlUp).Address & " ) "
            r.Offset(-2, -3).Formula = "=sum(" & r.Offset(-3, -3).Address & " : " & _
            r.Offset(-3, -3).End(xlUp).Address & " ) "
            r.Offset(-2, -2).Formula = "=sum(" & r.Offset(-3, -2).Address & " : " & _
            r.Offset(-3, -2).End(xlUp).Address & " ) "
        Next r
        rInsert.ClearContents
    End With
    Range("X25035").End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Selection.Borders.LineStyle = xlContinuous
    Sheets("Sheet3").Select
    Range("A1:X7").Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("A1:X1").Select
    ActiveSheet.Paste
    Application.ScreenUpdating = True
End Sub

Snasui Excel Forum

สอบถามเรื่องการรวม Code และปรับให้กระชับลง ครับ

สอบถามเรื่องการรวม Code และปรับให้กระชับลง ครับ

Re: สอบถามเรื่องการรวม Code และปรับให้กระชับลง ครับ

Re: สอบถามเรื่องการรวม Code และปรับให้กระชับลง ครับ

Re: สอบถามเรื่องการรวม Code และปรับให้กระชับลง ครับ

Re: สอบถามเรื่องการรวม Code และปรับให้กระชับลง ครับ

Re: สอบถามเรื่องการรวม Code และปรับให้กระชับลง ครับ