String operation VBA Excel

Question

I am struggling with the following problem. I want to do following operations on Input Col A and produce output in col B:

1.Remove Duplicates if any ( It was easy and completed )

2.Remove Leading and/or Trailing spaces from the string (It was easy as well and it's done )

3.COLLECT THE DIFFERENT TRANSLATIONS OF A WORD IN SAME CELL - AVOID DUPLICATES ( It's hard and I don't know how to proceed with this problem ) To understand this point have a look at input/output example.

Input:

     A
 absolution 
 absolution 
 absolutism 
 absolutism, absolute rule 
  absolutist   
  absolutist   
 absorb 
 absorb 
 absorb, bind 
 absorb, take up 
 absorb 
 absorb, imbibe, take up 
 absorb, sorb 
 absorb, take up 
 absorb, take up 
 absorb, imbibe 
 absorb 
 absorb 
 absorber 
 absorber 
 absorber

Output:

  col  B
absolution
absolutism, absolute rule
absolutist
absorb, bind, imbibe, take up, sorb
absorber

I tried with the following code but I am stuck on the third point/step

Option Explicit
Sub StrMac()
Dim wk As Worksheet
Dim i, j, l, m As Long
Dim strc, strd, fstrc, fstrd As String
Dim FinalRowC, FinalRowD As Long

Set wk = Sheet1

wk.Columns(1).Copy Destination:=wk.Columns(3)
wk.Columns(2).Copy Destination:=wk.Columns(4)

wk.Range("$C:$C").RemoveDuplicates Columns:=1, Header:=xlNo
wk.Range("$D:$D").RemoveDuplicates Columns:=1, Header:=xlNo


FinalRowC = wk.Range("C1048576").End(xlUp).Row
FinalRowD = wk.Range("D1048576").End(xlUp).Row


If FinalRowC >= FinalRowD Then
    j = FinalRowC
Else
    j = FinalRowD
End If

For i = 1 To j
    If wk.Range("C" & i).Text <> "" Then
        strc = wk.Range("C" & i).Text
        strc = Replace(strc, Chr(160), "")
        strc = Application.WorksheetFunction.Trim(strc)
        wk.Range("C" & i).Value = strc
    Else: End If

    If wk.Range("D" & i).Text <> "" Then
        strd = wk.Range("D" & i).Text
        strd = Replace(strd, Chr(160), "")
        strd = Application.WorksheetFunction.Trim(strd)
        wk.Range("D" & i).Value = strd
    Else: End If
Next i

Dim Cet, Det, Fet, Met, s As Variant
Dim newstr
Dim pos, cos As Long
s = 1

For i = 1 To j

     If wk.Range("D" & i).Text <> "" Then

        l = 2
        strd = wk.Range("D" & i).Text
        newstr = strd

        For m = i + 1 To j
            pos = 1100
            cos = 2300

            fstrd = wk.Range("D" & m).Text
            cos = InStr(1, fstrd, ",")
            pos = InStr(1, fstrd, strd, vbTextCompare)

            If wk.Range("D" & m).Text <> "" And Len(fstrd) > Len(strd) And m <= j And cos <> 2300 And pos = 1 Then
                l = 5
                        newstr = newstr & "," & fstrd
                        wk.Range("D" & m) = ""

            Else: End If

        Next m

        wk.Range("E" & s) = newstr
        s = s + 1
     Else: End If

Next i


End Sub

I haven't tried the code, but for a start - after step 1(remove duplicates as a whole and not single column basis) & 2, run text-to-column on resultant data. Then a tabular pivot of the data with everything in row area, subtotals removed, collapsed give expected result though not in your format. But then it will be very easy to convert in required format with a nested loop. I will elaborate this as an answer with VBA once I get time. — PankajR
– PankajR, Commented Jan 8, 2016 at 17:44

tigeravatar · Accepted Answer · 2016-01-08 18:59:30Z

Assuming your input is column A and you want the output in column B (as stated in your question), the following should work for you:

Sub tgr()

    Dim ws As Worksheet
    Dim rData As Range
    Dim aData As Variant
    Dim vData As Variant
    Dim vWord As Variant
    Dim aResults() As String
    Dim sUnq As String
    Dim i As Long

    Set ws = ActiveWorkbook.Sheets("Sheet1")
    Set rData = ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp))

    If rData.Cells.Count = 1 Then
        'Only 1 cell in the range, check if it's no blank and output it's text
        If Len(Trim(rData.Text)) > 0 Then ws.Range("B1").Value = WorksheetFunction.Trim(rData.Text)
    Else
        'Remove any extra spaces and sort the data
        With rData
            .Value = Evaluate("index(trim(" & .Address(external:=True) & "),)")
            .Sort .Cells, xlAscending, Header:=xlNo
        End With

        aData = rData.Value                             'Load all values in range to array
        ReDim aResults(1 To rData.Cells.Count, 1 To 1)  'Ready the results array

        For Each vData In aData
            'Get only unique words
            If InStr(1, vData, ",", vbTextCompare) = 0 Then
                If InStr(1, "," & sUnq & ",", "," & vData, vbTextCompare) = 0 Then
                    sUnq = sUnq & "," & vData
                    If i > 0 Then aResults(i, 1) = Replace(aResults(i, 1), ",", ", ")
                    i = i + 1
                    aResults(i, 1) = vData
                End If
            Else
                'Add unique different translations for the word
                For Each vWord In Split(vData, ",")
                    If InStr(1, "," & aResults(i, 1) & ",", "," & Trim(vWord) & ",", vbTextCompare) = 0 Then
                        aResults(i, 1) = aResults(i, 1) & "," & Trim(vWord)
                    End If
                Next vWord
            End If
        Next vData
    End If

    'Output results
    If i > 0 Then ws.Range("B1").Resize(i).Value = aResults

End Sub

Collectives™ on Stack Overflow

String operation VBA Excel

1 Answer 1

Comments

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Related