ตรวจสอบและปรับปรุงไฟล์ Excel ให้เร็วและเสถียรด้วย File Anatomy Add-in
เครื่องมือนี้ช่วยวิเคราะห์โครงสร้างไฟล์อย่างละเอียด เช่น สูตร, ลิงก์, PivotTable, Styles และ Objects
พร้อมฟังก์ชันล้างสิ่งเกินจำเป็นที่ทำให้ไฟล์ช้า หรือเสียหายได้ในคลิกเดียว
เหมาะสำหรับผู้ใช้ Excel ที่ต้องการควบคุมคุณภาพไฟล์อย่างมืออาชีพ
ทดลองใช้ Add-in
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
ระบุ Version ของ Excel 
โปรดทราบ สมัครสมาชิก
Login ผ่าน Facebook Reset รหัสผ่าน ติดต่อผู้ดูแลระบบ ตั้งค่าส่วนตัว วิธีการตั้งและตอบกระทู้ จัดรูปแบบตัวอักษร กำหนดขนาดตัวอักษรใน Browser
คำแสดงเจตนา[code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/code] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
ตัวอย่างสูตรตามด้านล่างครับ
ตัวอย่างสูตรตามด้านล่างครับ
การจัดการข้อมูลลักษณะนี้จำเป็นต้องมีรายละเอียดมาให้จนถือได้ว่าเป็นตัวแทนของข้อมูลทั้งหมดได้ ไม่ทราบว่านอกจากประเด็นดังกล่าวยังมีประเด็นอื่นอีกหรือไม่ กรุณาเขียนมาให้ครอบคลุม ในคราวต่อไปหากยังเลือกแนวทางการเขียนสูตรเช่นนี้หากเกิดประเด็นอื่นใดนอกเหนือจากที่ให้ข้อมูลมาแล้วจะต้องปรับปรุงมาเองก่อน ติดแล้วค่อยถามกัน จำเป็นต้องเรียนรู้เพื่อแก้ไขเองได้บ้างครับ จากตัวอย่างที่แนบมามีหลายรูปแบบและมีไม่ครบชุด อาจจะมี DF หรือ Add on หรือไม่ก็ได้ งานลักษณะนี้ไม่เหมาะที่จะใช้สูตรเข้าไปจัดการ ควรเขียนมาเป็น VBA มากกว่า ลองเขียนมาเองก่อน ติดตรงไหนค่อยถามกันต่อครับ ตัวอย่างตรง ๆ กับงานเช่นนี้แบบสำเร็จรูปไม่มีครับCode: Select all
Private Sub CommandButton1_Click()
'Define abbreviations for worksheets
Dim WI As Worksheet
Dim WF As Worksheet
Set WI = Worksheets("Input")
Set WF = Worksheets("Forms")
HeadingRow1 = WF.Range("FormsFirstLine1").Row
CurrentRow1 = HeadingRow1
For Each AmountCell1 In WI.Range("inputProcedure").Cells
If AmountCell1 <> "" Then
WF.Cells(HeadingRow1, 6) = ""
CurrentRow1 = CurrentRow1 + 1
WF.Cells(CurrentRow1, 1) = AmountCell1
End If
Next
For Each AmountCell1 In WI.Range("InputDoctorfree").Cells
If AmountCell1 <> "" Then
WF.Cells(HeadingRow1, 6) = ""
CurrentRow1 = CurrentRow1 + 1
WF.Cells(CurrentRow1, 1) = "Specail DF"
WF.Cells(CurrentRow1, 6) = Application.WorksheetFunction.Sum(AmountCell1.Offset(0, 1))
End If
Next
For Each AmountCell1 In WI.Range("InputProthsthesis").Cells
If AmountCell1 <> "" Then
WF.Cells(HeadingRow1, 6) = ""
CurrentRow1 = CurrentRow1 + 1
WF.Cells(CurrentRow1, 1) = "Prothsthesis"
WF.Cells(CurrentRow1, 6) = Application.WorksheetFunction.Sum(AmountCell1.Value)
End If
Next
For Each AmountCell1 In WI.Range("InputImplant").Cells
If AmountCell1 <> "" Then
WF.Cells(HeadingRow1, 6) = ""
CurrentRow1 = CurrentRow1 + 1
WF.Cells(CurrentRow1, 1) = "Implant"
WF.Cells(CurrentRow1, 6).Formula = Application.WorksheetFunction.Sum(AmountCell1.Value)
End If
Next
For Each AmountCell1 In WI.Range("InputOther").Cells
If AmountCell1 <> "" Then
WF.Cells(HeadingRow1, 6) = ""
CurrentRow1 = CurrentRow1 + 1
WF.Cells(CurrentRow1, 1) = "Other Charges"
WF.Cells(CurrentRow1, 6) = Application.WorksheetFunction.Sum(AmountCell1.Text)
End If
Next
For Each AmountCell1 In WI.Range("InputIncure").Cells
If AmountCell1 <> "" Then
WF.Cells(HeadingRow1, 6) = ""
CurrentRow1 = CurrentRow1 + 1
WF.Cells(CurrentRow1, 1) = AmountCell1.Offset(0, -7)
WF.Cells(CurrentRow1, 6) = AmountCell1.Text
End If
Next
Do While CurrentRow1 < WF.Range("FormsLastLine1").Row
CurrentRow1 = CurrentRow1 + 1
WF.Cells(CurrentRow1, 1) = ""
WF.Cells(CurrentRow1, 5) = ""
WF.Cells(CurrentRow1, 6) = ""
Loop
End Sub
Code: Select all
Sub Test()
Dim rall As Range
Dim r As Range, i As Integer
Dim j As Integer
Dim arr2 As Variant
Dim s As String
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
With Worksheets("Forms")
Set tg = .Range("i5")
Set rall = .Range("a5", .Range("a" & .Rows.Count).End(xlUp))
For Each r In rall
If i = 0 Then
arr2 = VBA.Split(VBA.Replace(VBA.Replace(r.Value, "2.", "|2."), "3.", "|3."), "|")
For j = 0 To UBound(arr2)
s = VBA.Replace(arr2(j), "THB)", "")
s = VBA.Replace(VBA.Trim(s), " ", String(20, " "))
s = VBA.Right(s, 20)
If IsNumeric(VBA.Right(s, 1)) Then
.Range("i5").Offset(i, 0) = arr2(j)
.Range("i5").Offset(i, 1) = CLng(s)
Else
.Range("i5").Offset(i, 0) = arr2(j)
End If
i = i + 1
Next j
Else
If Not d.exists(r.Value) Then
d.Add Key:=r.Value, Item:=r.Offset(0, 1).Value
Else
d.Item(r.Value) = d.Item(r.Value) + r.Offset(0, 1).Value
End If
End If
Next r
For Each itm In d.keys
.Range("i5").Offset(i, 0) = i + 1 & "." & itm
.Range("i5").Offset(i, 1) = d.Item(itm)
i = i + 1
Next itm
End With
End Sub