:D snasui.com ยินดีต้อนรับ :D
ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย :thup: สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ :arrow: ระบุ Version ของ Excel
:!: โปรดทราบ :!:
  1. กรุณาอ่านกฎการใช้บอร์ด (Forum rules) ในตำแหน่งด้านบนของแต่ละบอร์ด
  2. การสมัครสมาชิก การ Login การกู้คืนรหัสผ่าน
    1. สมัครสมาชิกดูขั้นตอนได้ที่ :arrow: สมัครสมาชิก
    2. Login เข้าระบบโดยคลิกปุ่ม Login ตรงมุมขวาบนของหน้านี้ :roll:
    3. การ Login ผ่าน Facebook ดูวิธีที่ :arrow: Login ผ่าน Facebook
    4. ลืมรหัสผ่านสามารถรับรหัสใหม่ได้ที่ :arrow: Reset รหัสผ่าน
  3. มีปัญหาการใช้งาน แจ้งผู้ดูแลระบบได้ที่ :arrow: ติดต่อผู้ดูแลระบบ
  4. กำหนดการตั้งค่าส่วนตัว เช่นตั้งค่าภาษาเป็นไทยหรืออังกฤษดูได้ที่ :arrow: ตั้งค่าส่วนตัว
  5. การตั้งและตอบกระทู้ดูได้ที่ :arrow: วิธีการตั้งและตอบกระทู้
  6. การจัดรูปแบบตัวอักษรด้วย bbcode ในช่องแสดงความคิดเห็นดูได้ที่ :arrow: จัดรูปแบบตัวอักษร
  7. กำหนดขนาดตัวอักษรใน Browser ดูได้ที่ :arrow: กำหนดขนาดตัวอักษรใน Browser
🪷 คำแสดงเจตนา
ขอผลแห่งการให้ความรู้นี้ จงกลับไปยังผู้ที่เป็นเจ้าของเดิม แม้ข้าพเจ้าจะไม่รู้จักท่านก็ตาม ขอให้แสงแห่งปัญญาที่ท่านเคยจุดไว้ ได้กลับไปเติมเต็มชีวิตของท่านอีกครั้ง และขอให้เจตนาของข้าพเจ้าเป็นการคืนความดีอย่างสงบ

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

ฟอรัมถาม-ตอบปัญหาการใช้งาน MS Excel and VBA
Forum rules
  1. ไม่อนุญาตให้ใช้ภาษาแชทในการถามและตอบปัญหา ไม่ใช้คำว่า "คับ" หรือ "อ่ะครับ" แทนคำว่า "ครับ" ไม่ใช้คำว่า "เด๋ว" แทนคำว่า "เดี๋ยว" เป็นต้น เนื่องจากเมื่อแปลเป็นภาษาต่างประเทศแล้วจะให้ความหมายผิดไปจากที่ควรจะเป็น
  2. ห้ามถามโดยระบุชื่อผู้ตอบและต้องตั้งชื่อกระทู้ให้สื่อถึงปัญหาที่จะถาม ไม่ตั้งชื่อว่า ช่วยด้วยครับ, มีปัญหามาปรึกษาครับ เป็นต้น
  3. กรุณาอธิบายปัญหาและระบุคำตอบที่ต้องการมาในกระทู้ด้วยเสมอถึงแม้จะอธิบายไว้ในไฟล์แนบแล้วก็ตาม ทั้งนี้เพื่ออำนวยความสะดวกแก่เพื่อนสมาชิกในการค้นหาข้อมูล
  4. กรุณาแนบไฟล์ตัวอย่างพร้อมแสดงคำตอบที่ถูกต้องมาในไฟล์ด้วยเพื่อให้ง่ายต่อการทำความเข้าใจและสะดวกต่อการตอบคำถาม (ขนาดไฟล์ไม่เกิน 500Kb ขนาดภาพไม่เกิน 800*600 Pixel) ไม่แนบเป็น Link มาจากแหล่งอื่นที่อาจจะถูกลบทิ้งไปโดยต้นทางในภายหลัง นอกจากนี้ไม่ควรแนบไฟล์ที่มีข้อมูลสำคัญอันก่อให้เกิดความเสียหายกับตนเองและผู้อื่น
  5. กรณีเป็นคำถามเกี่ยวกับ Programming เช่น VBA, VB.Net, C#, SQL ฯลฯ ต้องลองเขียนมาเองก่อนเสมอ ถามเฉพาะที่ติดปัญหา ระบุ Module, Procedure ที่ติดปัญหาให้ชัดเจน กรุณาโพสต์ Code ให้แสดงเป็น Code คือเปิดด้วย [code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/code] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
  6. กรุณาแจ้งผลการใช้งานเมื่อได้รับคำตอบว่าตรงกับความต้องการหรือไม่
Post Reply
niwat2811
Bronze
Bronze
Posts: 350
Joined: Thu Jan 06, 2011 12:51 pm
Excel Ver: 2016

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

#1

Post by niwat2811 »

สวัสดีครับท่านอาจารย์ คือว่าได้ลองประยุกต์ 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
Top
User avatar
snasui
Site Admin
Site Admin
Posts: 31176
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 2019
Contact:
Contact snasui

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

#2

Post by snasui »

:D แนบไฟล์ตัวอย่างมาด้วยครับ จะได้สะดวกในการสังเกตการทำงานของ Code ครับ
Top
niwat2811
Bronze
Bronze
Posts: 350
Joined: Thu Jan 06, 2011 12:51 pm
Excel Ver: 2016

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

#3

Post by niwat2811 »

ครับผม ตัวอย่างไฟล์แนบครับท่านอาจารย์
You do not have the required permissions to view the files attached to this post.
Top
User avatar
snasui
Site Admin
Site Admin
Posts: 31176
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 2019
Contact:
Contact snasui

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

#4

Post by snasui »

:shock: ปลด Password ออกจาก Project ก่อนแล้วแนบมาอีกรอบครับ :P
Top
niwat2811
Bronze
Bronze
Posts: 350
Joined: Thu Jan 06, 2011 12:51 pm
Excel Ver: 2016

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

#5

Post by niwat2811 »

ขอโทษด้วยครับอาจารย์ ไฟล์แนบใหม่นะครับ
You do not have the required permissions to view the files attached to this post.
Top
User avatar
snasui
Site Admin
Site Admin
Posts: 31176
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 2019
Contact:
Contact snasui

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

#6

Post by snasui »

:D กรณีต้องการรวม 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
Top
Post Reply

Return to “Excel”