Excel Forum

ฟอรัม Excel, VBA และอื่นๆ ของคนไทยเพื่อประโยชน์ของทุกคนในจักรวาล (Forum Excel, VBA and others of Thai people for everyone in the universe.)
https://www.snasui.com/

หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

https://www.snasui.com/viewtopic.php?t=19223

Page 1 of 1

หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Fri Jun 17, 2022 3:22 pm
by wisitsakbenz
เรียน อาจารย์

ที่ Sheet "AIA" หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์แสดงออกมาดัง Sheet "สิ่งที่อยากได้ Cholec"
1.และต้องการให้ ผลรวมมีค่าเท่ากับหัวข้อใหญ่ คือ 1-8 ที่ Highlight สีแดงครับ
2.ถ้ามีการเปลี่ยนชื่อ Cholec (235,000) ใน Sheet "Display" เป็น Unilateral (239,000) Clickปุ่ม Cal ที่ Sheet "AIA" จะแสดงตาม Sheet "สิ่งที่อยากได้ Unilateral"

ต้องปรับสูตรอย่างไรครับ

Code: Select all

Private Sub CommandButton1_Click()

            Dim rFind As Range, rDataAll As Range
            Dim r As Range, rTarget As Range
            Dim ws4 As Worksheet, i As Integer
                Set ws4 = Worksheets("AIA")
                Set rFind = Sheets("Display").Range("I7")
                Application.EnableEvents = False

                ws4.Range("C12:F1000").ClearContents
                
                If Sheets("Display").Range("I7") = "" Then Exit Sub
                
            With Sheets("Data")
            
            Worksheets("AIA").Range("C21").Resize(1000, 1).EntireRow.Delete

                    Set rDataAll = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
                    If .Columns("B:B").Find(rFind, LookIn:=xlValues) Is Nothing Then
                        MsgBox ("ไม่มี Package นี้")
                        Exit Sub
                    End If
                End With
                i = 12
                For Each r In rDataAll
                    If r = rFind Then
                        ws4.Range("d" & i).Resize(1, 2).Value = _
                            r.Offset(0, 1).Resize(1, 2).Value
                        i = i + 1
                    End If
                Next r
                   
        Worksheets("AIA").Range("C49:D49").Value = "Total"
        Worksheets("AIA").Range("E49:F49").Formula = "=Sum(R17C:R[-1]C)"
    Worksheets("AIA").Range("D12").Resize(600, 1).EntireRow.Insert
                
           With Sheets("AIA")
    .Range("d" & i + 2, .Range("d" & i).End(xlDown).Offset(-1, 0)) _
        .EntireRow.Delete
End With
                
                Application.EnableEvents = True
           ' MsgBox "Get data has finished."
            Set ws4 = Nothing
            Set rFind = Nothing
            Set rDataAll = Nothing
End Sub

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Fri Jun 17, 2022 5:03 pm
by snasui
:D ตัวอย่างการปรับ Code ครับ

Code: Select all

Private Sub CommandButton1_Click()

    Dim rFind As Range, rDataAll As Range
    Dim r As Range, rTarget As Range
    Dim ws4 As Worksheet, i As Integer
    Set ws4 = Worksheets("AIA")
    Set rFind = Sheets("Display").Range("I7")
    Application.EnableEvents = False
    
    ws4.Range("C12:F1000").ClearContents
    
    If Sheets("Display").Range("I7") = "" Then Exit Sub
    
    With Sheets("Data")
    
        Worksheets("AIA").Range("C21").Resize(1000, 1).EntireRow.Delete
        
        Set rDataAll = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
        If .Columns("B:B").Find(rFind, LookIn:=xlValues) Is Nothing Then
            MsgBox ("äÁèÁÕ Package ¹Õé")
            Exit Sub
        End If
    End With
    i = 12
    For Each r In rDataAll
        If r = rFind Then
            ws4.Range("d" & i).Resize(1, 2).Value = _
                r.Offset(0, 1).Resize(1, 2).Value
            If IsNumeric(VBA.Left(ws4.Range("d" & i), 1)) Then
                ws4.Range("d" & i).Resize(1, 2).Font.Bold = True
                ws4.Range("e" & i).Font.Color = vbRed
            End If
            i = i + 1
        End If
    Next r
    
'    Worksheets("AIA").Range("C49:D49").Value = "Total"
'
'    Worksheets("AIA").Range("E49:F49").Formula = "=Sum(R17C:R[-1]C)"
'    Worksheets("AIA").Range("D12").Resize(600, 1).EntireRow.Insert
    
    With Sheets("AIA")
        .Range("c10:f10").Copy
        .Range("d" & .Rows.Count).End(xlUp).Offset(3, -1).Resize(1, 4).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        With .Range("D" & .Rows.Count).End(xlUp).Offset(3, 0)
            .Offset(0, -1).Value = "Total"
            .Offset(0, 1).Formula = "=Sumifs(R11C:R[-1]C,R11C[-1]:R[-1]C[-1],""*.*"")"
            
'            .Range("D12").Resize(600, 1).EntireRow.Insert
'            .Range("d" & i + 2, .Range("d" & i).End(xlDown).Offset(-1, 0)) _
                .EntireRow.Delete
        End With
        .Range("e17", .Range("e" & .Rows.Count).End(xlUp)).NumberFormat = "#,##0"

        With .Range("e17", .Range("e" & .Rows.Count).End(xlUp)).Offset(0, -2)
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(0, 1).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(0, 3).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        End With
    End With
    
    Application.EnableEvents = True
    ' MsgBox "Get data has finished."
    Set ws4 = Nothing
    Set rFind = Nothing
    Set rDataAll = Nothing
End Sub

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Sat Jun 18, 2022 10:50 am
by wisitsakbenz
เรียน อาจารย์ snasui ครับ

ได้ผลตามต้องการครับ แต่อยากเพิ่มเติมคือ
1.Sheet "AIA" > Highlight สีตามหัวข้อ (ตัวอย่างตาม Sheet "สิงที่อยากได้ AIA")
2.Sheet "AIA-Detail"
- อยากให้แสดงผลรวม
- Highlight สีตามหัวข้อ
ดังตัวอย่าง Sheet "สิ่งที่อยากได้ AIADetail"

ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all


        With Sheets("AIA-Detail")
        .Range("c10:g11").Copy
        .Range("d" & .Rows.Count).End(xlUp).Offset(3, -1).Resize(1, 4).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        With .Range("D" & .Rows.Count).End(xlUp).Offset(3, 0)
            .Offset(0, -1).Value = "Total"
            .Offset(0, 1).Formula = "=Sumifs(R11C:R[-1]C,R11C[-1]:R[-1]C[-1],""*.*"")"
            .EntireRow.Delete
        End With

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Sat Jun 18, 2022 6:24 pm
by snasui
:D ตัวอย่างการปรับ Code ครับ

Code: Select all

Private Sub CommandButton1_Click()

    Dim rFind As Range, rDataAll As Range
    Dim r As Range, rTarget As Range
    Dim ws4 As Worksheet, i As Integer
    Set ws4 = Worksheets("AIA")
    Set ws5 = Worksheets("AIA-Detail")
    Set rFind = Sheets("Display").Range("I7")
    Application.EnableEvents = False
    
    ws4.Range("C12:F1000").ClearContents
    ws5.Range("C13:k1000").ClearContents
    
    If Sheets("Display").Range("I7") = "" Then Exit Sub
    
    With Sheets("Data")
    
        Worksheets("AIA").Range("C21").Resize(1000, 1).EntireRow.Delete
        
        Set rDataAll = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
        If .Columns("B:B").Find(rFind, LookIn:=xlValues) Is Nothing Then
            MsgBox ("äÁèÁÕ Package ¹Õé")
            Exit Sub
        End If
    End With
    i = 12
    For Each r In rDataAll
        If r = rFind Then
            ws4.Range("d" & i).Resize(1, 2).Value = _
                r.Offset(0, 1).Resize(1, 2).Value
            If IsNumeric(VBA.Left(ws4.Range("d" & i), 1)) Then
                ws4.Range("d" & i).Resize(1, 2).Font.Bold = True
                ws4.Range("d" & i).Offset(0, -1).Resize(1, 4).Interior.Color = _
                    ws4.Range("c10").Interior.Color
               ' ws4.Range("e" & i).Font.Color = vbRed
            End If
            i = i + 1
        End If
    Next r
    
'    Worksheets("AIA").Range("C49:D49").Value = "Total"
'
'    Worksheets("AIA").Range("E49:F49").Formula = "=Sum(R17C:R[-1]C)"
'    Worksheets("AIA").Range("D12").Resize(600, 1).EntireRow.Insert
    
    With Sheets("AIA")
        .Range("c10:f10").Copy
        .Range("d" & .Rows.Count).End(xlUp).Offset(3, -1).Resize(1, 4).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        With .Range("D" & .Rows.Count).End(xlUp).Offset(3, 0)
            .Offset(0, -1).Value = "Total"
            .Offset(0, 1).Formula = "=Sumifs(R11C:R[-1]C,R11C[-1]:R[-1]C[-1],""*.*"")"
            
'            .Range("D12").Resize(600, 1).EntireRow.Insert
'            .Range("d" & i + 2, .Range("d" & i).End(xlDown).Offset(-1, 0)) _
                .EntireRow.Delete
        End With
        .Range("e17", .Range("e" & .Rows.Count).End(xlUp)).NumberFormat = "#,##0"

        With .Range("e17", .Range("e" & .Rows.Count).End(xlUp)).Offset(0, -2)
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(0, 1).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(0, 3).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        End With
    End With
    
      'Other Sheet
        
    With Sheets("Datadetail")
    
        Worksheets("AIA-Detail").Range("C21").Resize(1000, 1).EntireRow.Delete
        
        Set rDataAll = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
        If .Columns("B:B").Find(rFind, LookIn:=xlValues) Is Nothing Then
            MsgBox ("äÁèÁÕ Package ¹Õé")
            Exit Sub
        End If
    End With
    i = 13
    For Each r In rDataAll
        If r = rFind Then
            ws5.Range("d" & i).Resize(1, 4).Value = _
                r.Offset(0, 1).Resize(1, 4).Value
            If IsNumeric(VBA.Left(ws5.Range("d" & i), 1)) Then
                ws5.Range("d" & i).Resize(1, 4).Font.Bold = True
                ws5.Range("d" & i).Offset(0, -1).Resize(1, 5).Interior.Color = _
                    ws5.Range("c10").Interior.Color
               ' ws4.Range("e" & i).Font.Color = vbRed
            End If
            i = i + 1
        End If
    Next r
    With Sheets("AIA-Detail")
        .Range("c10:g11").Copy
        .Range("d" & .Rows.Count).End(xlUp).Offset(3, -1).Resize(1, 5).PasteSpecial xlPasteFormats
        With .Range("d" & .Rows.Count).End(xlUp).Offset(3, -1)
            .Resize(1, 5).PasteSpecial xlPasteFormats
            .Offset(0, 1).UnMerge
            With .Resize(1, 3)
                .Merge
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeRight).Weight = xlMedium
                .Offset(0, 1).Resize(1, 2).Merge
            End With
        End With

        Application.CutCopyMode = False
        With .Range("D" & .Rows.Count).End(xlUp).Offset(3, 0)
            .Offset(0, -1).Value = "Total"
            .Offset(0, 1).Formula = "=Sumifs(R11C:R[-1]C,R11C[-2]:R[-1]C[-2],""*.*"")"
'            .EntireRow.Delete
        End With
        .Range("e11", .Range("f" & .Rows.Count).End(xlUp)).NumberFormat = "#,##0"
'        .Range("f" & .Rows.Count).End(xlUp).NumberFormat = "#,##0"
        With .Range("f17", .Range("f" & .Rows.Count).End(xlUp)).Offset(0, -3)
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(0, 1).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(0, 2).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(0, 4).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        End With
        With .Range("f" & .Rows.Count).End(xlUp).Offset(0, -3).Resize(1, 5).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
        End With
    End With
            
    Application.EnableEvents = True
    ' MsgBox "Get data has finished."
    Set ws4 = Nothing
    Set rFind = Nothing
    Set rDataAll = Nothing
End Sub

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Sat Jun 18, 2022 8:12 pm
by wisitsakbenz
เรียน อาจารย์ snasui

ได้แล้วครับ ขอบคุณอาจารย์มากเลยครับ

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Mon Jun 20, 2022 9:44 am
by wisitsakbenz
เรียน อาจารย์ snasui

อยากสอบถามเพิ่มเติมครับ คือ
1. ถ้าใส่ --> Hernia Repair (380,000) ในช่อง I7 ของ Sheet "Display" แล้วคลิกปุ่ม Cal ใน sheet "AIA"
จะแสดงผลผิดพลาด คือ เส้นเกิน และมีสีเกินครับ (อยากให้แสดงผลดัง Sheet "สิ่งที่อยากได้ AIA" และ "สิ่งที่อยากได้ Datadetail"
2.ถ้ากลับไปใส่ Cholec (235,000) หรือ Unilateral (239,000) ในช่อง I7 ของ Sheet "Display" แล้วคลิกปุ่ม Cal ใน sheet "AIA"
Row ที่ 15 จะไม่แสดงค่า และมีการ Merge Cell ใส่สี ใส่เส้น

ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Mon Jun 20, 2022 10:02 am
by snasui
:D ได้เขียนปรับ Code มาเองแล้วหรือไม่ เขียนไว้ว่าอย่างไรครับ

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Mon Jun 20, 2022 10:34 am
by wisitsakbenz
เรียน อาจารย์ snasui

ขอศึกษาก่อนนะครับ หากติดขัดจะสอบถามอีกครั้งครับ
ขอบคุณครับ

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Mon Jun 20, 2022 10:36 am
by snasui
:D กรุณา Debug แล้วสังเกตมาเองว่าข้อมูลควรจะเริ่มกำหนดรูปแบบตั้งแต่บรรทัดไหน ใน Code กำหนดไว้ที่บรรทัดไหน กลับไปแก้บรรทัดนั้นให้ครอบคลุมในสิ่งที่ต้องการครับ

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Mon Jun 20, 2022 10:38 am
by wisitsakbenz
เรียน อาจารย์ snasui

ขอศึกษาก่อนนะครับ หากติดขัดจะสอบถามอีกครั้งครับ
ขอบคุณครับ

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Fri Jun 24, 2022 9:55 am
by wisitsakbenz
เรียน อาจารย์ snasui ครับ

อยากสอบถามเพิ่มเติมคือ
Sheet "AIA" >
- เส้นขาด
- อยากให้แสดงข้อความด้านล่างแสดง ต่อจาก "รวมราคาท้้งหมด"


หมายเหตุ : ราคาดังกล่าวไม่รวมค่าใช้จ่ายดังต่อไปนี้
* การรักษาโรคประจำตัว
* การรักษาภาวะแทรกซ้อน
* ค่ารักษา ค่าส่งตรวจ

ดังตัวอย่าง Sheet "สิ่งที่อยากได้"

ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

        
        With Sheets("AIA")
        .Range("c10:f10").Copy
        .Range("d" & .Rows.Count).End(xlUp).Offset(3, -1).Resize(1, 4).PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        With .Range("D" & .Rows.Count).End(xlUp).Offset(3, 0)
            .Offset(0, -1).Value = "รวมราคาท้้งหมด  " & ws4.Range("L11").Value & "  บาท"
          
                
        End With
           
    With .Range("d12", .Range("d" & .Rows.Count).End(xlUp)).Offset(0, -1)
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(0, 3).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        End With
    End With

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Fri Jun 24, 2022 11:17 am
by snasui
:D ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
'With .Range("d12", .Range("d" & .Rows.Count).End(xlUp)).Offset(0, -1)
With .Range("c12", .Range("c" & .Rows.Count).End(xlUp))
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    With .Offset(0, 3).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
End With
With .Range("c" & .Rows.Count).End(xlUp)
    .Offset(2, 0).Value = "หมายเหตุ : ราคาดังกล่าวไม่รวมค่าใช้จ่ายดังต่อไปนี้"
    .Offset(2, 0).Font.Bold = True
    .Offset(3, 0).Value = "* การรักษาโรคประจำตัว"
    .Offset(4, 0).Value = "* การรักษาภาวะแทรกซ้อน"
    .Offset(5, 0).Value = "* ค่ารักษา ค่าส่งตรวจ"
End With
'Other code
สิ่งที่ต้องทำความเข้าใจและใช้ให้คล่องมีดังนี้ครับ
  1. การเยื้อง Code จะต้องปรับการเข้าคู่ให้เยื้องตรงกันแม้จะไม่มีผลต่อการทำงานของ Code แต่จะสะดวกต่อการอ่านและการ Debug ลักษณะการเยื้องที่ควรเป็น เช่น

    Code: Select all

    With
  'xyz
End With

If
  'xyz
End If

For x = 0 to 10
  'xyz
Next x
  2. การหาตำแหน่งที่จะ Offset
    1. การ Merge เซลล์ ค่าที่คีย์ในเซลล์จะบรรจุอยู่ในเซลล์แรกของชุดเซลล์ที่ Merge และหากการ Merge อยู่บรรทัดสุดท้าย เมื่อจะอ้างอิงหาบรรทัดสุดท้ายของข้อมูลจะต้องใช้คอลัมน์ของเซลล์ดังกล่าว
    2. วิธีการตรวจสอบหาบรรทัดสุดท้ายของข้อมูลอย่างง่าย ๆ ให้คลิกไปยังเซลล์ว่างด้านล่างข้อมูล จากนั้นกดแป้น Ctrl ค้างไว้แล้วกดแป้นลูกศรชี้ขึ้น หาก Cursor ไม่หยุดยังเซลล์สุดท้ายที่มีข้อมูลแสดงว่าคอลัมน์นั้นใช้อ้างอิงหาค่าบรรทัดสุดท้ายของข้อมูลไม่ได้

Re: หลังจากที่ Clickปุ่ม Cal แล้ว อยากให้ผลลัพธ์ที่ต้องการ

Posted: Fri Jun 24, 2022 11:40 am
by wisitsakbenz
เรียน อาจารย์ snasui

ได้แล้วครับ ขอบคุณอาจารย์มากเลยครับ
All times are UTC+07:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited