Code Combination

Below code is used to create combination of strings

Function Code_Combination()
    'Macro Number :: 121 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Dim mval As String
    Dim Myval As String
    Dim cadd() As Range
    Dim mcell() As Range
    Dim mrng As Range
    Dim i As Long
    Dim e As Long
    Dim clm As Long
    Dim n As Long
    Dim msheet As String
    Dim oSheet As String
    e = 1
    uMsg = ""
    oSheet = "OUTPUT_SHEET"
    On Error Resume Next
    Set mrng = Application.InputBox(Prompt:="Please select begning cell.", Title:="www.excelmacroclasses.com", Type:=8)
    If Err.Number <> 0 Then
        uMsg = Err.Description
        GoTo endFunction
    End If
    If mrng.Address = "" Then
        uMsg = "No Cell Address found"
        GoTo endFunction
    End If
    appstart
    msheet = ActiveSheet.Name
    Sheets(oSheet).Delete
    Sheets.Add.Name = oSheet
    Sheets(oSheet).Range("A1").Value = "Sr No#"
    Sheets(oSheet).Range("B1").Value = "Combination"
    Sheets(msheet).Activate
    mrng.Select
    On Error GoTo 0
'    i = 0
'    Do
'        DoEvents
'        i = i + 1
'    Loop Until IsEmpty(mrng.Offset(0, i)) = True
    i = mrng.CurrentRegion.Columns.Count
    ReDim cadd(i)
    ReDim mcell(i)
    Dim tc As Integer
    tc = i - 1
    i = 0
    Do
        DoEvents
        Set cadd(i) = mrng.Offset(0, i)
        Set mcell(i) = cadd(i)
        i = i + 1
    Loop Until IsEmpty(mrng.Offset(0, i)) = True
    Range("I:I").ClearContents
    clm = 1
    For n = tc To 0 Step -1
        DoEvents
        Do
            DoEvents
            Do
                DoEvents
step1:
                For i = 0 To tc
                    DoEvents
                    mval = mcell(i).Value
                    Myval = Myval & "-" & mval
                    If IsEmpty(mcell(i)) = True Then
                        Set mcell(i) = cadd(i)
                        Set mcell(i - 1) = mcell(i - 1).Offset(1, 0)
                        Myval = ""
                        GoTo step1
                    End If
                Next
                i = tc
                Set mcell(tc) = mcell(tc).Offset(1, 0)
                Sheets(oSheet).Range("A1").Offset(e, 0).Value = e
                Sheets(oSheet).Range("A1").Offset(e, 1).Value = Myval
                Application.StatusBar = e
                e = e + 1
                Myval = ""
            Loop Until IsEmpty(mcell(tc)) = True
            For i = 0 To tc
                DoEvents
                If IsEmpty(mcell(i)) = True Then
                    If IsEmpty(mcell(0)) = True Then GoTo endFunction
                    Set mcell(i) = cadd(i)
                    Set mcell(i - 1) = mcell(i - 1).Offset(1, 0)
                    If IsEmpty(mcell(i - 1)) = True Then
                        On Error GoTo endFunction
                        Set mcell(i - 1) = cadd(i - 1)
                        Set mcell(i - 2) = mcell(i - 2).Offset(1, 0)
                    End If
                End If
            Next
            clm = clm + 1
        Loop Until clm = tc
    Next
    uMsg = "Finish"
endFunction:
On Error Resume Next
    For i = 0 To tc
        DoEvents
        Set cadd(i) = Nothing
        Set mcell(i) = Nothing
    Next
    If uMsg <> "" Then MsgBox uMsg, vbInformation, EMC
    append
End Function

Total Page Visits: 126 - Today Page Visits: 2

Leave a Reply