Posts by keerthi deva

keerthi deva · Apr 18th 2016

Re: Calculating end date based on start date and effort hours

Ok Pike!

keerthi deva · Apr 18th 2016

Re: Calculating end date based on start date and effort hours

Workday function return only M to F how to include Saturday and Sunday?

keerthi deva · Apr 13th 2016

Re: Extract dollar amount from cell

Hi,

I have problem for extracting $ amount and percentage. Because I have used multiple patterns for extract amount!

Code

Sub spliter()
Dim r As Range, I As Long, m As Object
    Application.DisplayAlerts = False
     
        Call SPACER
        Sheets("Riven").Select
        For Each r In Range("C1", Range("C" & Rows.Count).End(xlUp))
         
         With CreateObject("VBScript.Regexp")
        .Global = True
        .IgnoreCase = True
        
         
             
          .Pattern = "(\$\d+\d+)|(\$(\d+(\,\d+)?))|(\$\d+,\d+)|(\b\d+\d+\%)|(\b\d+\%)"
            If .test(r.Value) Then
                Set m = .Execute(r.Value)
                For I = 0 To m.Count - 1
                    r(, 2 + I).Value = m(I)
                   Next
             End If
                  
           
           .Pattern = "(\$\d+,\d+)|(\$\d+\d+)"
            If .test(r.Value) Then
                Set m = .Execute(r.Value)
                For I = 0 To m.Count - 1
                    r(, 2 + I).Value = m(I)
                   Next
             End If
                  
          
           .Pattern = "(Emergency Room Services at Hospital Network or Non-Network\-\-)(\$\d+)( Copayment per visit, plus an additional )?(\d+%)?"
            
            If .test(r.Value) Then
                'ws2.Range("A" & Rows.Count).End(xlUp)(2) = r.Offset(, -2)
                'ws2.Range("B" & Rows.Count).End(xlUp)(2) = r.Offset(, -1)
                 Set m = .Execute(r.Value)
                 For I = 0 To m.Count - 1
                 r(, 2 + I).Value = .Execute(r)(I).submatches(1) & IIf(.Execute(r)(I).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(I).submatches(3))
                 Next
             End If
           
           
          .Pattern = "(Inpatient Facility--)(\$\d+)( Copayment per admission, plus an additional )?(\d+%)?"
            
            If .test(r.Value) Then
               
                 Set m = .Execute(r.Value)
                 For I = 0 To m.Count - 1
                  r(, 2 + I).Value = .Execute(r)(I).submatches(1) & IIf(.Execute(r)(I).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(I).submatches(3))
                 Next
             End If
             
            .Pattern = "(Inpatient Facility--)(\$\d+\,\d+)( Copayment per admission, plus an additional )?(\d+%)?"
            
            If .test(r.Value) Then
               
                 Set m = .Execute(r.Value)
                 For I = 0 To m.Count - 1
                  r(, 2 + I).Value = .Execute(r)(I).submatches(1) & IIf(.Execute(r)(I).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(I).submatches(3))
                 Next
             End If
             
             
             .Pattern = "(Outpatient Surgery Hospital/Alternative Care Facility\-\-)(\$\d+)( Copayment per visit, plus an additional )?(\d+%)?"
            
            If .test(r.Value) Then
               
                 Set m = .Execute(r.Value)
                 For I = 0 To m.Count - 1
                  r(, 2 + I).Value = .Execute(r)(I).submatches(1) & IIf(.Execute(r)(I).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(I).submatches(3))
                 Next
             End If
             
            .Pattern = "(Outpatient Surgery Hospital/Alternative Care Facility\-\-)(\$\d+\,\d+)( Copayment per visit, plus an additional )?(\d+%)?"
            
            If .test(r.Value) Then
               
                 Set m = .Execute(r.Value)
                 For I = 0 To m.Count - 1
                  r(, 2 + I).Value = .Execute(r)(I).submatches(1) & IIf(.Execute(r)(I).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(I).submatches(3))
                 Next
             End If
             
             
              .Pattern = "(Inpatient Facility Mental Health & Substance Abuse\-\-)(\$\d+)( Copayment per admission, plus an additional )?(\d+%)?"
            
            If .test(r.Value) Then
               
                 Set m = .Execute(r.Value)
                 For I = 0 To m.Count - 1
                  r(, 2 + I).Value = .Execute(r)(I).submatches(1) & IIf(.Execute(r)(I).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(I).submatches(3))
                 Next
             End If
             
             
             .Pattern = "(Inpatient Facility Mental Health & Substance Abuse\-\-)(\$\d+\,\d+)( Copayment per admission, plus an additional )?(\d+%)?"
            
            If .test(r.Value) Then
               
                 Set m = .Execute(r.Value)
                 For I = 0 To m.Count - 1
                  r(, 2 + I).Value = .Execute(r)(I).submatches(1) & IIf(.Execute(r)(I).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(I).submatches(3))
                 Next
             End If
             
             
             
              .Pattern = "(Physician Home and Office Services\-\-)(\$\d+)( Copayment per visit, plus an additional )?(\d+%)?"
            
            If .test(r.Value) Then
               
                 Set m = .Execute(r.Value)
                 For I = 0 To m.Count - 1
                  r(, 2 + I).Value = .Execute(r)(I).submatches(1) & IIf(.Execute(r)(I).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(I).submatches(3))
                 Next
             End If
             
             
           End With
       
        Next
    
    Application.DisplayAlerts = True
End Sub

Display More

This code producing wrong result!

I want extract same order which is in cell ! if % comes first then extract!!! Hope You understand! Please find the attachment! FYI

regards,
Dev

keerthi deva · Apr 11th 2016

Re: Extract words based on Font color

Hi pike,

Each cell have red color fonts.I want to extract words in adjacent cell which is in red font.

regards,
dev

keerthi deva · Apr 8th 2016

Hi,

I need macro to Extract red fonts from cell :witch:Quickly. I have done one Function. But it takes more time to show output. :oops:

So I need better one!!! Please find the below code!:fyi:

Code

Function GetColorText(r As Range) As String
Dim s As String, t As String, x As Long
t = r.Text
For x = 1 To Len(t)
    If r.Characters(x, 1).Font.Color = vbRed Then s = s & Mid(t, x, 1)
Next
GetColorText = s
End Function

Regards,
dev

keerthi deva · Apr 5th 2016

Re: Extract dollar amount from cell

Is there any way to find dollar amount with their % values based on string?

Please find the attachments!!!!

keerthi deva · Apr 4th 2016

Re: Extract dollar amount from cell

Perfect! Thank you!:)

keerthi deva · Apr 1st 2016

Re: Extract dollar amount from cell

Please find the attachment...... :smile:

keerthi deva · Apr 1st 2016

Hi folks,

I need help for Extracting dollar amounts from cell.

I have done one code but that code extract only 4 digit values !

For example $5000 if my excel have $15000 it track only $15! can any one say where I miss?

Here is my code FYI......

Code

Sub spliter()
'Call Command
Dim r As Range, i As Long, m As Object
    Application.DisplayAlerts = False
    With CreateObject("VBScript.Regexp")
        .Global = True
        .IgnoreCase = True
         .Pattern = "(\$\d+\d+)|(\$(\d+(\,\d+)?))|(\b\d+\d+\%)"
        For Each r In Range("C1", Range("C" & Rows.Count).End(xlUp))
            If .test(r.Value) Then
                Set m = .Execute(r.Value)
                For i = 0 To m.Count - 1
                    r(, 2 + i).Value = m(i)
                Next
            End If
        Next
    End With
    Application.DisplayAlerts = True
End Sub

Display More

Thanks & Regards,
dev

keerthi deva · Mar 31st 2016

Re: split,Copy paste cell Based on Criteria

Based on your coding I can change some lines based on my requirements. But result comes only first pattern its not moving to next if condition! I don't know why? Could you say where I wrong?

please find my below code... FYI

Code

Sub spliter()
'Call Command
Dim r As Range, i As Long, m As Object
    Application.DisplayAlerts = False
        '.Pattern = "\$\d+\d+"
        '.Pattern = "\$(\d+(\,\d+)?)"
         
       
        For Each r In Range("C1", Range("C" & Rows.Count).End(xlUp))
         
         With CreateObject("VBScript.Regexp")
        .Global = True
        .IgnoreCase = True
        .Pattern = "(apple\-\-)(\$\d+)( and)?(\d+%)?"
            
            If .Test(r.Value) Then
                'ws2.Range("A" & Rows.Count).End(xlUp)(2) = r.Offset(, -2)
                'ws2.Range("B" & Rows.Count).End(xlUp)(2) = r.Offset(, -1)
                 Set m = .Execute(r.Value)
                 For i = 0 To m.Count - 1
                 r(, 2 + i).Value = .Execute(r)(0).submatches(1) & IIf(.Execute(r)(0).submatches(3) = vbNullString, "", "/" & _
                .Execute(r)(0).submatches(3))
                 Next
        End if
        .Pattern = "(\$\d+\d+)|(\$(\d+(\,\d+)?))|(\b\d+\d+\%)"
            if .Test (r.Value) then
                Set m = .Execute(r.Value)
                For i = 0 To m.Count - 1
                    r(, 2 + i).Value = m(i)
                   Next
             End If
           
            
           End With
       
        Next
    
    Application.DisplayAlerts = True
End Sub

Display More

keerthi deva · Mar 31st 2016

Re: split,Copy paste cell Based on Criteria

Could you please Explain this lines? I am not able to understand!

Code

ws2.Range("B" & Rows.Count).End(xlUp)(2) = .Execute(r)(0).submatches(1) & IIf(.Execute(r)(0).submatches(3) = vbNullString, "", "/" & _ 
                .Execute(r)(0).submatches(3))

keerthi deva · Mar 31st 2016

Re: split,Copy paste cell Based on Criteria

Awesome!!!:cool: works perfectly!!! Thank you very much!:thanx:

keerthi deva · Mar 31st 2016

Re: compare 2 columns and highlight words that don't match then split difference

Finally I found this code!

Code

Option Explicit
Sub HIGHLIGHT()
    Dim myList As New Collection
    Dim myCell, myColl, myObject, myItem
    Dim myKey As String, myarray As String
    For Each myCell In Range("A2", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItem = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value, myCell.Offset(0, 2).Value)
                Call myItem.Add(Item:=myObject)
            Next myObject
            On Error Resume Next
            Call myList.Add(Item:=myItem, Key:=myKey)
            If Err.Number = 457 Then
                On Error GoTo 0
                myarray = myList.Item(myKey)(3)
                myList.Remove myKey
                myarray = myarray & myCell.Offset(0, 2).Value
                Set myItem = New Collection
                For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value, myarray)
                    Call myItem.Add(Item:=myObject)
                Next myObject
                Call myList.Add(Item:=myItem, Key:=myKey)
            End If
        End If
    Next myCell
    For Each myColl In myList
        Cells(Rows.Count, "F").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl(3))
    Next myColl
    Range("F1:H1").Value = Range("A1:C1").Value
      
End Sub

Display More

But its getting late can any one say solution?

keerthi deva · Mar 31st 2016

Re: split,Copy paste cell Based on Criteria

First of all Thank you for your time!

I have data in same format which is in file but each cell have more no. of sentences. But "apple" and "orange" words are comes one time in each cell. :read:

Also apple values are end with before orange and spaces.

For example, common thing is highlighted below,

we received Apple profit--$150 and orange profit--- $52 and 20%

I want split after apple before orange if any $ and % numbers are there combine and paste target cell. same for Orange data also.

Hope u have any idea on over all!

Regards,
Dev

keerthi deva · Mar 29th 2016

Hi All,

Inopportunely I don't know much about the VBA language so I'll appreciate it if you could help me on this. I want macro to split dollar and percentage values based on prefix string and copy result and paste based on next sheet Headers and ID. I have attached sample workbook.
Thank you in advance.

Regards,
Dev

keerthi deva · Mar 28th 2016

Hi,

I have a large amount of data in each cell in column A and B . I want to compare and highlight words that don't match. For that I try the below macro. I want to split that red fonts string to next cell. But I have trouble in splitting red font words because it takes more time for splitting. Anyone have better macro for compare and split the difference? I have attached macro workbook which I tried.

I want macro to display output like this,

[TABLE="width: 500"]

[tr]

[td]

A

[/td]

[td]

B

[/td]

[td]

C

[/td]

[/tr]

[tr]

[td]

AAAB

[/td]

[td]

AAA

[/td]

[td]

B

[/td]

[/tr]

[/TABLE]

thanks & Regards,
Deva

keerthi deva · Nov 21st 2015

Re: Extract Only Red fonts

Quote from pike;760404

Hi For a range of cells try

Code

Option Explicit
Function redPart(rngcells As Range) As String
    Dim res As String
   Dim rngItem As Range
   Dim i As Long
   For Each rngItem In rngcells
    With rngItem
        For i = 1 To Len(.Value)
             ' red = RGB(255, 0, 0)
            If .Characters(i, 1).Font.Color = RGB(255, 0, 0) Then
                res = res & .Characters(i, 1).Text
            End If
        Next
    End With
        Next
    redPart = res
End Function

Display More

Thank you very much pike!:ole::ole::dance:

keerthi deva · Nov 17th 2015

Hi All,

I have tried to Extract only red highlighted words in next cell.I found macro for that.It was working perfectly but my problem is i dont know how to fill that function in Entire B Column. Also i want another function to extract red fonts from A column because this get delay to produce result.

MY CODE is

Code

Function redPart(x As Range) As String
    Dim res As String
    With x
        For i = 1 To Len(.Value)
            ' red = RGB(255, 0, 0)
            If .Characters(i, 1).Font.Color = RGB(255, 0, 0) Then
                res = res & .Characters(i, 1).Text
            End If
        Next
    End With
    redPart = res
End Function

Display More

it give the result,

[TABLE="class: grid, width: 500"]

[tr]

[td]

BASE

[/td]

[td]

VALUES

[/td]

[/tr]

[tr]

[td]

Apple

[/td]

[td]

pl

[/td]

[/tr]

[tr]

[td]

Orange

[/td]

[td]

an

[/td]

[/tr]

[/TABLE]

I could call that function in B2 cell like,
"=redPart(A2)" and then select range of cells down Ctrl+D and then only i get the result for all cells. I am new to this excel vba so i dont know looping coding for this.

Regards,
keerthi

keerthi deva · Nov 16th 2015

Re: Auto fill data based on Criteria

Quote from cytop;760271

You're simply repeating what you said in your first post...

Explain the logic. 'Roy P' is not the same as 'Roy O'. I'm not going to make the assumption that anything starting 'Roy' gets the ID '01' - it's down to you to explain.

Yes, I want fill where ever Roy comes fill the ID 01

keerthi deva · Nov 16th 2015

Re: Auto fill data based on Criteria

Quote from cytop;760261

There's no common field to link the lists and you haven't explained how/why the various Roys (for example) all get '01' as the status.

Hi,

I want to fill id based on name .

Regards,
Keerthi