Snasui Excel Forum

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