Can u suggest a VBA code for this excel formula

Kichan

Board Regular
Joined
Feb 21, 2022
Messages
67
Office Version
  1. 2010
Platform
  1. Windows
hi guys...
I got this excel formula from jtakw and mackc557 .. and its working perfectly thank you guys ... Can anyone suggest a VBA code for this formulae.. Thank you




Cell Formulas
RangeFormula
B2:B5B2=TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))
C2:C5C2=IFERROR(SUBSTITUTE(A2,TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"-",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))&",",""),"")
D2:D5D2=IFERROR(SUBSTITUTE(TRIM(LEFT(SUBSTITUTE(C2,",",IF(ISNUMBER(FIND("/",C2,FIND("/",C2)+1)),REPT(" ",100),","),LEN(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)))-LEN(SUBSTITUTE(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)),",",""))),100)),B2,""),"")
E2:E5E2=IF(D2="","",MID(SUBSTITUTE(SUBSTITUTE(A2,B2&",",""),D2,""),2,99))
F2:F5F2=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(B2,",",","&LEFT(B2,FIND("/",B2)))&" "&IFERROR(SUBSTITUTE(D2,",",","&LEFT(D2,FIND("/",D2))),"")&IFERROR(" "&SUBSTITUTE(E2,",",","&LEFT(E2,FIND("/",E2))),""))," ",","),"/","-")
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Please try this code. The answers will be generated in column G.( c.Offset(0, 6) =Col G)
VBA Code:
Sub sample()
Dim  i As Long
Dim  buf As String
Dim c, x, z

With Sheets("Sheet1")
    For Each c In .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp))
        x = Split(c, ",")
        For i = 0 To UBound(x)
            If InStr(x(i), "/") > 0 Then
                buf = Left(x(i), InStr(x(i), "/") - 1)
                x(i) = Replace(x(i), "/", "-")
                z = z & "," & x(i)
            Else
                x(i) = buf & "-" & x(i)
                z = z & "," & x(i)
            End If
        Next
        c.Offset(0, 6).Value = Mid(z, 2, 1000)
        z = ""
    Next
End With
End Sub
 
Upvote 0
VBA Code:
Function GetAnswer(Question As String) As String
    Dim I As Long
    Dim S As String
    Dim Prefix As String
    Dim CA As Variant

    CA = Split(Replace(Question, "/", "/,"), ",")
    For I = 0 To UBound(CA)
        If InStr(CA(I), "/") > 0 Then
            Prefix = Split(CA(I), "/")(0)
        Else
            S = S & Prefix & "-" & CA(I) & ","
        End If
    Next I
    GetAnswer = Left(S, Len(S) - 1)
End Function

Results:
Cell Formulas
RangeFormula
B2:B5B2=TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))
C2:C5C2=IFERROR(SUBSTITUTE(A2,TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"-",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))&",",""),"")
D2:D5D2=IFERROR(SUBSTITUTE(TRIM(LEFT(SUBSTITUTE(C2,",",IF(ISNUMBER(FIND("/",C2,FIND("/",C2)+1)),REPT(" ",100),","),LEN(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)))-LEN(SUBSTITUTE(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)),",",""))),100)),B2,""),"")
E2:E5E2=IF(D2="","",MID(SUBSTITUTE(SUBSTITUTE(A2,B2&",",""),D2,""),2,99))
F2:F5F2=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(B2,",",","&LEFT(B2,FIND("/",B2)))&" "&IFERROR(SUBSTITUTE(D2,",",","&LEFT(D2,FIND("/",D2))),"")&IFERROR(" "&SUBSTITUTE(E2,",",","&LEFT(E2,FIND("/",E2))),""))," ",","),"/","-")
G2:G5G2=GetAnswer(A2)
H2:H5H2=F2=G2
 
Upvote 0
Please try this code. The answers will be generated in column G.( c.Offset(0, 6) =Col G)
VBA Code:
Sub sample()
Dim  i As Long
Dim  buf As String
Dim c, x, z

With Sheets("Sheet1")
    For Each c In .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp))
        x = Split(c, ",")
        For i = 0 To UBound(x)
            If InStr(x(i), "/") > 0 Then
                buf = Left(x(i), InStr(x(i), "/") - 1)
                x(i) = Replace(x(i), "/", "-")
                z = z & "," & x(i)
            Else
                x(i) = buf & "-" & x(i)
                z = z & "," & x(i)
            End If
        Next
        c.Offset(0, 6).Value = Mid(z, 2, 1000)
        z = ""
    Next
End With
End Sub
wow .. its working perfectly bro .. superb .. can i ask you something bro that in this question the second question is 850/A-B,C,D and the answer is 850-A-B, 850-A-C,850-A-D . (in this case the items before "-" is constant ,"850-A-" . Can we add this to the same code ... Question no. 6 is also in this format

Thank you for your reply .. have a good day bro..
 
Upvote 0
VBA Code:
Function GetAnswer(Question As String) As String
    Dim I As Long
    Dim S As String
    Dim Prefix As String
    Dim CA As Variant

    CA = Split(Replace(Question, "/", "/,"), ",")
    For I = 0 To UBound(CA)
        If InStr(CA(I), "/") > 0 Then
            Prefix = Split(CA(I), "/")(0)
        Else
            S = S & Prefix & "-" & CA(I) & ","
        End If
    Next I
    GetAnswer = Left(S, Len(S) - 1)
End Function

Results:
Cell Formulas
RangeFormula
B2:B5B2=TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))
C2:C5C2=IFERROR(SUBSTITUTE(A2,TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"-",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))&",",""),"")
D2:D5D2=IFERROR(SUBSTITUTE(TRIM(LEFT(SUBSTITUTE(C2,",",IF(ISNUMBER(FIND("/",C2,FIND("/",C2)+1)),REPT(" ",100),","),LEN(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)))-LEN(SUBSTITUTE(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)),",",""))),100)),B2,""),"")
E2:E5E2=IF(D2="","",MID(SUBSTITUTE(SUBSTITUTE(A2,B2&",",""),D2,""),2,99))
F2:F5F2=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(B2,",",","&LEFT(B2,FIND("/",B2)))&" "&IFERROR(SUBSTITUTE(D2,",",","&LEFT(D2,FIND("/",D2))),"")&IFERROR(" "&SUBSTITUTE(E2,",",","&LEFT(E2,FIND("/",E2))),""))," ",","),"/","-")
G2:G5G2=GetAnswer(A2)
H2:H5H2=F2=G2

VBA Code:
Function GetAnswer(Question As String) As String
    Dim I As Long
    Dim S As String
    Dim Prefix As String
    Dim CA As Variant

    CA = Split(Replace(Question, "/", "/,"), ",")
    For I = 0 To UBound(CA)
        If InStr(CA(I), "/") > 0 Then
            Prefix = Split(CA(I), "/")(0)
        Else
            S = S & Prefix & "-" & CA(I) & ","
        End If
    Next I
    GetAnswer = Left(S, Len(S) - 1)
End Function

Results:
Cell Formulas
RangeFormula
B2:B5B2=TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))
C2:C5C2=IFERROR(SUBSTITUTE(A2,TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"-",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))&",",""),"")
D2:D5D2=IFERROR(SUBSTITUTE(TRIM(LEFT(SUBSTITUTE(C2,",",IF(ISNUMBER(FIND("/",C2,FIND("/",C2)+1)),REPT(" ",100),","),LEN(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)))-LEN(SUBSTITUTE(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)),",",""))),100)),B2,""),"")
E2:E5E2=IF(D2="","",MID(SUBSTITUTE(SUBSTITUTE(A2,B2&",",""),D2,""),2,99))
F2:F5F2=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(B2,",",","&LEFT(B2,FIND("/",B2)))&" "&IFERROR(SUBSTITUTE(D2,",",","&LEFT(D2,FIND("/",D2))),"")&IFERROR(" "&SUBSTITUTE(E2,",",","&LEFT(E2,FIND("/",E2))),""))," ",","),"/","-")
G2:G5G2=GetAnswer(A2)
H2:H5H2=F2=G2
Thank you brother .. Its perfect .. good work bro

one thing or bro .. I forgot to tell you a thing in this table that in this question the second question is 850/A-B,C,D and the answer is 850-A-B, 850-A-C,850-A-D . (in this case the items before "-" is constant ,"850-A-" . Can we add this to the same code ... Question no. 6 is also in this format

Thank you for your reply .. have a good day bro..
Book1.xlsx
ABCDEF
1QuestionAnswer
21/1,2,3,2/A,B,C1/1,2,32/A,B,C2/A,B,C 1-1,1-2,1-3,2-A,2-B,2-C
3850/A-B,C,D   850-A-B,850-A-C,850-A-D
450/8,6,2/5,1,4/5,550/8,62/5,1,4/5,52/5,14/5,550-8,50-6,2-5,2-1,4-5,4-5
51000/5-2,6-8,1-91000/5-2,6-8,1-9   1000-5-2,1000-6-8,1000-1-9
63/2-12,13,14   3-2-12,3-2-13,3-2-14
Sheet1
Cell Formulas
RangeFormula
B2,B4:B5B2=TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))
C2:C6C2=IFERROR(SUBSTITUTE(A2,TRIM(LEFT(SUBSTITUTE(A2,",",IF(ISNUMBER(FIND("/",A2,FIND("/",A2)+1)),REPT(" ",100),","),LEN(LEFT(A2,FIND("/",A2&"-",FIND("/",A2)+1)))-LEN(SUBSTITUTE(LEFT(A2,FIND("/",A2&"/",FIND("/",A2)+1)),",",""))),100))&",",""),"")
D2:D6D2=IFERROR(SUBSTITUTE(TRIM(LEFT(SUBSTITUTE(C2,",",IF(ISNUMBER(FIND("/",C2,FIND("/",C2)+1)),REPT(" ",100),","),LEN(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)))-LEN(SUBSTITUTE(LEFT(C2,FIND("/",C2&"/",FIND("/",C2)+1)),",",""))),100)),B2,""),"")
E2:E6E2=IF(D2="","",MID(SUBSTITUTE(SUBSTITUTE(A2,B2&",",""),D2,""),2,99))
F2,F4:F5F2=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(B2,",",","&LEFT(B2,FIND("/",B2)))&" "&IFERROR(SUBSTITUTE(D2,",",","&LEFT(D2,FIND("/",D2))),"")&IFERROR(" "&SUBSTITUTE(E2,",",","&LEFT(E2,FIND("/",E2))),""))," ",","),"/","-")
 
Upvote 0
one thing or bro .. I forgot to tell you a thing in this table that in this question the second question is 850/A-B,C,D and the answer is 850-A-B, 850-A-C,850-A-D . (in this case the items before "-" is constant ,"850-A-" . Can we add this to the same code ... Question no. 6 is also in this format
That's not what's in your OP, so I'm not sure I follow. The point of this was to replicate what your formula does in VBA. In your original post, question "850/A-B,C,D" produces an answer "850-A-B,850-C,850-D" using the formula you provided. My replacement UDF was designed to replicate that formula and produces the same "850-A-B,850-C,850-D" answer.

If you want the answer to be "850-A-B,850-A-C,850-A-D", then the question would need to be "850/A-B,A-C,A-D"
 
Upvote 0
wow .. its working perfectly bro .. superb .. can i ask you something bro that in this question the second question is 850/A-B,C,D and the answer is 850-A-B, 850-A-C,850-A-D . (in this case the items before "-" is constant ,"850-A-" . Can we add this to the same code ... Question no. 6 is also in this format

Thank you for your reply .. have a good day bro..
Please test this code. Sorry this is not beautiful.
VBA Code:
Sub sample()
Dim i As Long, j As Long
Dim buf As String
Dim c, x, z, y()

    With Sheets("Sheet1")
        For Each c In .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp))
            x = Split(c, ",")
            For i = 0 To UBound(x)
                If InStr(x(i), "/") > 0 Then
                    If InStr(x(i), "-") > 0 Then
                        buf = Replace(Left(x(i), InStr(x(i), "/") + 1), "/", "-")
                    Else
                        buf = Replace(Left(x(i), InStr(x(i), "/") + 1), "/", "-")
                    End If
                    x(i) = buf & Replace(Replace(x(i), "/", "-"), buf, "")
                    z = z & "," & x(i)
                Else
                    x(i) = buf & "-" & x(i)
                    z = z & "," & x(i)
                End If
            Next
            ReDim Preserve y(j)
            y(j) = Mid(z, 2, 1000)
            j = j + 1
            z = ""
        Next
        .Range(.Range("G2"), .Cells(UBound(y) + 2, 7)).Value = WorksheetFunction.Transpose(y)
    End With
End Sub

Thanks,
Takae
 
Upvote 0
Solution
That's not what's in your OP, so I'm not sure I follow. The point of this was to replicate what your formula does in VBA. In your original post, question "850/A-B,C,D" produces an answer "850-A-B,850-C,850-D" using the formula you provided. My replacement UDF was designed to replicate that formula and produces the same "850-A-B,850-C,850-D" answer.

If you want the answer to be "850-A-B,850-A-C,850-A-D", then the question would need to be "850/A-B,A-C,A-D"
ya bro.. i just forgot that .. sory:) ..

thank you brother
 
Upvote 0
Please test this code. Sorry this is not beautiful.
VBA Code:
Sub sample()
Dim i As Long, j As Long
Dim buf As String
Dim c, x, z, y()

    With Sheets("Sheet1")
        For Each c In .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp))
            x = Split(c, ",")
            For i = 0 To UBound(x)
                If InStr(x(i), "/") > 0 Then
                    If InStr(x(i), "-") > 0 Then
                        buf = Replace(Left(x(i), InStr(x(i), "/") + 1), "/", "-")
                    Else
                        buf = Replace(Left(x(i), InStr(x(i), "/") + 1), "/", "-")
                    End If
                    x(i) = buf & Replace(Replace(x(i), "/", "-"), buf, "")
                    z = z & "," & x(i)
                Else
                    x(i) = buf & "-" & x(i)
                    z = z & "," & x(i)
                End If
            Next
            ReDim Preserve y(j)
            y(j) = Mid(z, 2, 1000)
            j = j + 1
            z = ""
        Next
        .Range(.Range("G2"), .Cells(UBound(y) + 2, 7)).Value = WorksheetFunction.Transpose(y)
    End With
End Sub

Thanks,
Takae
Ha Ha :biggrin: dont say that bro .. It is beautiful .. Just asking Can we make a code for both the cases , like one i said before the second question is 850/A-B,C,D and the answer is 850-A-B, 850-A-C,850-A-D . (in this case the items before "-" is constant ,"850-A-" . Can we add this to the same code ... Question no. 6 is also in this format .. and in the first question it is 1/1,2,3,2/A,B,C and the answer is 1-1,1-2,1-3,2-A,2-B,2-C (in this case the items before "/" is constant ,"1/" and "2/" . How to do both cases in a single code ..
I just started a VBA course and just got variable section only... its a long way i have to go to make codes like this :biggrin: .

Thank you bro .. take care Takae


Book1
AB
1QuestionAnswer TO BE
21/1,2,3,2/A,B,C1-1,1-2,1-3,2-A,2-B,2-C
3850/A-B,C,D850-A-B,850-A-C,850-A-D
450/8,6,2/5,1,4/5,550-8,50-6,2-5,2-1,4-5,4-5
51000/5-2,6-8,1-91000-5-2,1000-6-8,1000-1-9
635/4-25,2,2635-4-25,35-4-2,35-4-26
Sheet1
 
Upvote 0
Ha Ha :biggrin: dont say that bro .. It is beautiful .. Just asking Can we make a code for both the cases , like one i said before the second question is 850/A-B,C,D and the answer is 850-A-B, 850-A-C,850-A-D . (in this case the items before "-" is constant ,"850-A-" . Can we add this to the same code ... Question no. 6 is also in this format .. and in the first question it is 1/1,2,3,2/A,B,C and the answer is 1-1,1-2,1-3,2-A,2-B,2-C (in this case the items before "/" is constant ,"1/" and "2/" . How to do both cases in a single code ..
I just started a VBA course and just got variable section only... its a long way i have to go to make codes like this :biggrin: .

Thank you bro .. take care Takae


Book1
AB
1QuestionAnswer TO BE
21/1,2,3,2/A,B,C1-1,1-2,1-3,2-A,2-B,2-C
3850/A-B,C,D850-A-B,850-A-C,850-A-D
450/8,6,2/5,1,4/5,550-8,50-6,2-5,2-1,4-5,4-5
51000/5-2,6-8,1-91000-5-2,1000-6-8,1000-1-9
635/4-25,2,2635-4-25,35-4-2,35-4-26
Sheet1
I think my second code supports both.
 
Upvote 0

Forum statistics

Threads
1,224,820
Messages
6,181,160
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top