Summary Details

yukioh · #1

สะหวัดดีครับ อาจารย์

ขออนุญาตรบกวนสอบถาม VBA ครับ

ผมมีข้อมูลอยู่ในตาราง sheet "DETAIL" ชิ่งตะต้องใส่ข้อมูน
และ มี sheet "SUM" จะเป้น summary ข้อมูล ที่เราใส่ทุกอย่าง sheet "DETAIL"

ดูเหมือนว่า ตอนนีมันทำงานช้ามากครับ อาจารย์ ผมอยากให้ code ทำงานให้เร็วขิ้น

รบกวนอาจารย์ข่วยดูให้ด้วยครับ

Code: Select all

 
Sub summary()

Sheets("data").Visible = True
Worksheets.Add(After:=Worksheets(1)).Name = "data2"
Worksheets.Add(After:=Worksheets(1)).Name = "sheet4"
'************************************************
Sheets("Sheet4").Select

Range("A1") = "DESCRIPTION"
Range("B1") = "ACCT"
Range("C1") = "D-AMOUNT"
Range("D1") = "C-AMOUNT"
Range("E1") = "COX1"
Range("F1") = "COX2"
Range("G1") = "COX3"
Range("H1") = "COX4"
Range("I1") = "COX5"
Range("J1") = "COX6"
Range("K1") = "COX7"
Range("L1") = "COX8"
Range("M1") = "COX9"
Range("N1") = "COX10"


 
Sheets("data2").Select
Range("A8") = "DESCRIPTION"
Range("B8") = "ACCT"
Range("C8") = "D-AMOUNT"
Range("D8") = "C-AMOUNT"
Range("E8") = "COX1"
Range("F8") = "COX2"
Range("G8") = "COX3"
Range("H8") = "COX4"
Range("I8") = "COX5"
Range("J8") = "COX6"
Range("K8") = "COX7"
Range("L8") = "COX8"
Range("M8") = "COX9"
Range("N8") = "COX10"

'***************************
Sheets("Sheet4").Select
    Range("A2:V498").Select

    Selection.ClearContents
    Range("A2").Select
    Sheets("DETAIL").Select
    Range("Q10:AD130").Select
    Selection.Copy
    Sheets("Sheet4").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    Range("C2:C1000").Select
    Selection.ClearContents

 Range("A2").Select
'*********************************************
Range("A1:n100").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)
'******************************

Range("A1:N185").Select
    
    

    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("N2:N121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("B2:B121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
        ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("e2:e121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range("A1:N121")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A2").Select
    
    '**************************************
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'**************************************************

      Dim sa1 As String
     Dim sa2 As String
      Dim sa3 As String
       Dim sa4 As String
        Dim sa5 As String
    
    
 Application.ScreenUpdating = False
 
 
For i = 2 To 122


 sa1 = Application.Worksheets("sheet4").Cells(i, 1)
 sa2 = Application.Worksheets("sheet4").Cells(i, 2)
sa3 = Application.Worksheets("sheet4").Cells(i, 5)
  
  
  
  
  Application.Worksheets("detail").Activate
   
   
   ActiveSheet.Range("$Q$9:$AD$129").AutoFilter Field:=1, Criteria1:=sa1
    ActiveSheet.Range("$Q$9:$AD$129").AutoFilter Field:=2, Criteria1:=sa2
    ActiveSheet.Range("$Q$9:$AD$129").AutoFilter Field:=5, Criteria1:=sa3
    ActiveSheet.Range("$Q$9:$AD$129").AutoFilter Field:=13
    Range("Q10:AD130").Select
    Range("AD130").Activate
    Selection.Copy

    
    Application.Worksheets("data").Activate
     Range("a2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    
    Range("a1").Select
Application.Worksheets("detail").Activate

'**************************************

  Cells.Select
    Range("J1").Activate
    ActiveSheet.ShowAllData
    Range("J1").Select

'******************************************

Range("Q2").Select
'*******************************

Dim lastRow As Long
 
    Sheets("data").Select
 
    Range("A1:N1").Select
    Selection.Copy

    Sheets("data2").Select
    
    lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
 

     ActiveSheet.Cells(lastRow + 1, "A").Select
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A5").Select
    
        Sheets("data").Select
    
   '***********************************

 Application.Worksheets("data").Activate
    Range("A2:S317").Select
    Selection.ClearContents
    Range("A2").Select

'********************************************
Next i
 Application.ScreenUpdating = True

'*******************************
    
    Sheets("data2").Select
    Range("A9:N129").Select
    Range("N9").Activate
    Selection.Copy
    Sheets("SUM").Select
    Range("A9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A9").Select
    
    '********************************

Application.DisplayAlerts = False


Sheets("data2").Delete
Sheets("Sheet4").Delete

Application.DisplayAlerts = True

Sheets("data").Visible = False


End Sub

ดั่งตัวอย่างไฟล์ที่แนบมา

snasui · #2

ใน Code เกิดจากการบันทึก Macro แล้วนำมาปรับใช้ จึงเกิด Code ที่เป็นการ Select เซลล์ไว้จำนวนมาก ควรจะปรับ Code การ Select ออกไปให้มากที่สุดเท่าที่จะทำได้ครับ ตัวอย่างการปรับ Code บางส่วน

Code: Select all

Sheets("Sheet4").Select
'    Range("A2:V498").Select

    Range("A2:V498").ClearContents
'    Range("A2").Select
    Sheets("DETAIL").Select
'    Range("Q10:AD130").Select
    Range("Q10:AD130").Copy
    Sheets("Sheet4").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'    Range("A2").Select
'    Range("C2:C1000").Select
    Range("C2:C1000").ClearContents

' Range("A2").Select
'*********************************************
Range("A1:n100").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)

สังเกตว่าเมื่อมีการเลือกชีตแล้ว หากต้องการดำเนินการใดกับเซลล์ในชีทนั้น ให้เขียนเพื่อดำเนินการได้เลย ไม่จำเป็นต้อง Select เซลล์นั้นอีก เช่น หากต้องการ ClearContents ก็ให้เขียน Clear ได้เลย ไม่ต้องทำการ Select เซลล์นั้นอีก เป็นต้น

สิ่งที่ทำให้ช้าอีกประการคือการกระพริบของหน้าจอและการคำนวณ ให้แทรก Code ด้านล่างนี้ไว้ด้านบน Code ทั้งหมด

Code: Select all

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

และแทรก Code ด้านล่างไว้ก่อนจบ Procedure คือแทรกไว้ก่อน End Sub

Code: Select all

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

yukioh · #3

ครับ อาจารย์,
ผมได้ทำตามแล้วครับ แต่ดู่เหมือนว่า มันยังช้า
อาจารย์พอจะมี code ตัวไหน ที่ไม่ใช้การบันทึก Macro ไหมครับ
รบกวน อาจารย์ ด้วยครับ

Code: Select all

 
Sub summary()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Sheets("data").Visible = True
Worksheets.Add(After:=Worksheets(1)).Name = "data2"
Worksheets.Add(After:=Worksheets(1)).Name = "sheet4"
'************************************************
Sheets("Sheet4").Select

Range("A1") = "DESCRIPTION"
Range("B1") = "ACCT"
Range("C1") = "D-AMOUNT"
Range("D1") = "C-AMOUNT"
Range("E1") = "COX1"
Range("F1") = "COX2"
Range("G1") = "COX3"
Range("H1") = "COX4"
Range("I1") = "COX5"
Range("J1") = "COX6"
Range("K1") = "COX7"
Range("L1") = "COX8"
Range("M1") = "COX9"
Range("N1") = "COX10"

Sheets("data2").Select
Range("A8") = "DESCRIPTION"
Range("B8") = "ACCT"
Range("C8") = "D-AMOUNT"
Range("D8") = "C-AMOUNT"
Range("E8") = "COX1"
Range("F8") = "COX2"
Range("G8") = "COX3"
Range("H8") = "COX4"
Range("I8") = "COX5"
Range("J8") = "COX6"
Range("K8") = "COX7"
Range("L8") = "COX8"
Range("M8") = "COX9"
Range("N8") = "COX10"

'***************************
Sheets("Sheet4").Select
    Range("A2:V498").ClearContents
    
    'Range("A2").Select
    Sheets("DETAIL").Select
    Range("Q10:AD130").Copy
    Sheets("Sheet4").Select
    Range("A2").Select
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'    Range("A2").Select
    Range("C2:C1000").ClearContents

 'Range("A2").Select
'*********************************************
Range("A1:n100").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)
'******************************

Range("A1:N185").Select

    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("N2:N121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("B2:B121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
        ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("e2:e121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range("A1:N121")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'Range("A2").Select
    
    '**************************************
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'**************************************************

      Dim sa1 As String
     Dim sa2 As String
      Dim sa3 As String
       Dim sa4 As String
        Dim sa5 As String
    
 Application.ScreenUpdating = False
 
For i = 2 To 122

    sa1 = Application.Worksheets("sheet4").Cells(i, 1)
    sa2 = Application.Worksheets("sheet4").Cells(i, 2)
    sa3 = Application.Worksheets("sheet4").Cells(i, 5)
  
  Application.Worksheets("detail").Activate
   
    ActiveSheet.Range("$Q$9:$AD$129").AutoFilter Field:=1, Criteria1:=sa1
    ActiveSheet.Range("$Q$9:$AD$129").AutoFilter Field:=2, Criteria1:=sa2
    ActiveSheet.Range("$Q$9:$AD$129").AutoFilter Field:=5, Criteria1:=sa3
    ActiveSheet.Range("$Q$9:$AD$129").AutoFilter Field:=13
    Range("Q10:AD130").Copy
'    Range("AD130").Activate
 '   Selection.Copy
  
    Application.Worksheets("data").Activate
     Range("a2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
Calculate
    Range("a1").Select
Application.Worksheets("detail").Activate

'**************************************

 ' Cells.Select
 '   Range("J1").Activate
    ActiveSheet.ShowAllData
 '   Range("J1").Select

'******************************************

'Range("Q2").Select
'*******************************

Dim lastRow As Long
 
    Sheets("data").Select
 
    Range("A1:N1").Copy

    Sheets("data2").Select
    
    lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
 

     ActiveSheet.Cells(lastRow + 1, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    'Range("A5").Select
    
        Sheets("data").Select
    
   '***********************************

 Application.Worksheets("data").Activate
    Range("A2:S317").ClearContents
    'Range("A2").Select

'********************************************
Next i
 Application.ScreenUpdating = True

'*******************************
    
    Sheets("data2").Select
    Range("A9:N129").Select
    Range("N9").Activate
    Selection.Copy
    Sheets("SUM").Select
    Range("A9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    'Range("A9").Select
    
    '********************************

Application.DisplayAlerts = False

Sheets("data2").Delete
Sheets("Sheet4").Delete

Application.DisplayAlerts = True
Sheets("data").Visible = False

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

snasui · #4

ที่ว่าช้านั้น ช้าขนาดไหนครับ

จากตัวอย่างที่แนบมานั้นผม Run แล้วไม่ได้ช้ามากนัก

ช่วยอธิบายวิธีการทำงานท้้งหมดมาใหม่อีกรอบจะได้ช่วยดูว่ามีขั้นตอนไหนที่สามารถจะปรับปรุงให้เร็วขึ้นได้ครับ

yukioh · #5

ครับ อาจารย์,

ึความต้องกานก็คือ อยากจะทำกานรวมข้อมูล Summary แบบ unique ไม้มีตัวซ้ำกัน
ตัวอย่างเช่น:
sheet( detail ) เอาไว้ใส่ข้อมูลแบบละเอียด อย่างเช่น A = 10
A = 11
B = 12
sheet (SUM) ข้อมูลแบบละสรุปลวม จะได้ A = 21
B = 12 เป็นต้นครับ

รบกวน อาจารย์ ด้วยครับ

snasui · #6

ช่วยอธิบายโดยอ้างอิงถึงช่วงเซลล์ที่ใช้จริง จะได้อ้างอิงกันได้

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

yukioh · #7

ครับ อาจารย์

ต้องการรวมค่า Unique จากชีต "Detail" เลี้มจาก Q10:ADxx รวมไปไว้ที่ชีต "SUM" ตรง A9, และรวมจํานวนตัวเลขเข้าด้วยกัน
ตัวอย่างพาบ:

Untitled.png

snasui · #8

ตัวอย่าง Code ครับ

Code: Select all

Sub summary()
    Dim rngDesc As Range, rngAcct As Range
    Dim rngDAmt As Range, rngCox1 As Range
    Dim rngRmvDup As Range, rngRD As Range
    
    With Sheets("DETAIL")
        Set rngDesc = .Range("q10", .Range("q" & .Rows.Count).End(xlUp))
        Set rngAcct = rngDesc.Offset(0, 1)
        Set rngDAmt = rngDesc.Offset(0, 2)
        Set rngCox1 = rngDesc.Offset(0, 4)
    End With
    
    Sheets("data").Visible = True

    Worksheets.Add(After:=Worksheets(1)).Name = "sheet4"
    '************************************************
    Sheets("DETAIL").Range("q7:ad7").Copy Sheets("Sheet4").Range("a1")
    Sheets("Sheet4").Select
    Range("A2:V498").ClearContents
    
    'Range("A2").Select
    Sheets("DETAIL").Select
    Range("Q10:AD130").Copy
    Sheets("Sheet4").Select
    Range("A2").Select
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    '    Range("A2").Select
    Range("C2:C1000").ClearContents
    
     'Range("A2").Select
    '*********************************************
    Range("A1:n100").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)
    '******************************
    
    Range("A1:N185").Select
    
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("N2:N121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("B2:B121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
        ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("e2:e121") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range("A1:N121")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    With Sheets("sheet4")
        Set rngRmvDup = .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
        For Each rngRD In rngRmvDup
            rngRD.Offset(0, 2).Value = Application.SumIfs(rngDAmt, rngDesc, rngRD.Value, _
                rngAcct, rngRD.Offset(0, 1).Value, rngCox1, rngRD.Offset(0, 4).Value)
        Next rngRD
        
    End With
    Sheets("Sheet4").Range("a1").CurrentRegion.Copy Sheets("SUM").Range("a8")
    Application.DisplayAlerts = False
    Sheets("Sheet4").Delete
    Application.DisplayAlerts = True
    Sheets("data").Visible = False
    
End Sub

Excel Forum

EXCEL TOOLS

Summary Details

Summary Details

Re: Summary Details

Re: Summary Details

Re: Summary Details

Re: Summary Details

Re: Summary Details

Re: Summary Details

Re: Summary Details