Automate selection and paging process

The attached excel file contains a script that will take a range of numbers and create combinations based on those numbers. The goal here is to automate the process.

For instance,

Using B10:AG10 create combinations based those numbers in a page named 'Numbers_1'.
Using B11:AG11 create combinations based those numbers in a page named 'Numbers_2'.
Using B12:AG12 create combinations based those numbers in a page named 'Numbers_3'.

etc, etc, until it is finished. When it is finished there should be 10 separately numbered pages with the respective combinations.
CreateCominations.xlsm
Pedrov664Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

[ fanpages ]IT Services ConsultantCommented:
Given the misunderstanding/miscommunication in your previous question thread, I would like to clarify if the sample workbook provided is, in fact, a representative sample of the data/layout/format &/or content of the actual workbook you will be using.
0
Pedrov664Author Commented:
If you mean does sheet 1 represent the data to be analyzed then yes.

The outcome of the data will be combinations of 5 numbers culled from that data.

You can run the script included to see the expected result. The result should be placed on the pages after the first page so not to confuse the data. I hope that clarifies it for you.
0
Pedrov664Author Commented:
Fanpages,

Do you intend to work on this?
0
Introduction to R

R is considered the predominant language for data scientist and statisticians. Learn how to use R for your own data science projects.

[ fanpages ]IT Services ConsultantCommented:
...and do you wish to retain the data created within the [Numbers_1] to [Numbers_10] worksheets if you re-execute the creation of combinations, or should those worksheets be deleted & re-created on each successive execution.

Additionally, are there any other requirements you have not stated already?
0
[ fanpages ]IT Services ConsultantCommented:
Fanpages,

Do you intend to work on this?

I am keen not to repeat the experience in the earlier question where you added to the requirements, failed to provide exact details, & accepted another solution even after confirming that my previously provided code was functioning as you had originally requested.

This may be a recurring nature of your questions, so I would like to clarify all the requirements in advance.
0
Pedrov664Author Commented:
I any event where the script is looking for specific placement simply let me know just to avoid Any misunderstandings. I will assume you're still working on the code and await your code posting.

Thank you
0
[ fanpages ]IT Services ConsultantCommented:
I am still waiting for your response to my query from earlier today:

...and do you wish to retain the data created within the [Numbers_1] to [Numbers_10] worksheets if you re-execute the creation of combinations, or should those worksheets be deleted & re-created on each successive execution.
0
Pedrov664Author Commented:
Delete and recreate on each successive execution
0
Pedrov664Author Commented:
fanpages,

Any idea of when this item will be scripted?

Pedro
0
[ fanpages ]IT Services ConsultantCommented:
Hi,

In response to your request for attention (yesterday), "Fanpages is not responding. Is it possible to have someone else assigned to this project?", anybody may contribute to this thread.  I have not taken "ownership"; I never do.  There is never just a single party assigned to answering questions.  I am not assigned to any project at Experts-Exchange.  I am here as a volunteer.

I do try to offer suggestions/proposals to meet requirements within the same week they have been asked, if I am able to, but this is not possible on every occasion.

Please let me re-read the thread, look at your attachment, & remind myself of what you require, & I will endeavour to respond with some Visual Basic for Applications code applied to the original workbook within the next 24 hours or so.

As I said though, any other member of the site may also contribute in the meantime.

BFN,

fp.
0
[ fanpages ]IT Services ConsultantCommented:
Hi again,

The code below has been taken from the attached workbook.

I have amended the original "CreateCombinations" subroutine, & added three (optional) parameters to it.  I have commented each line (with the date [16/09/2013]) that has been changed so that you can see these lines easily.

There is also a new subroutine, "Q_28233532", that initially removes any worksheets that have a name that begins with "Numbers_" & end with a numeric value (e.g. [Numbers_1], [Numbers_2],... [Numbers_10], & beyond if applicable).

There is then an array of range references for each of the ten rows you mentioned would be required to be processed.

I took the liberty of defining the ranges in a manner so if you ever wish to remove, change, or add any range addresses to be processed you can simply follow the same pattern.

A new worksheet is created for each subsequent range that is processed, & named accordingly with a prefix of "Numbers_" & a suffix of the sequential position in the array list.

Each range to be processed is then used as an input to the "CreateCombinations" routine (together with the destination range; cell [A1] of the newly created worksheet, & the number 5 to indicate the number of combinations as you requested).

When all the (ten) individual range addresses have been processed, the execution concludes.

You will then see the results of the output from the CreateCombinations() subroutine in the respective newly-created worksheets.

Option Explicit
Public Sub Q_28233532()

' --------------------------------------------------------------------------------------------------------------
' [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28233532.html ]
'
' Question Channel: Experts Exchange > Software > Office / Productivity > Office Suites > MS Office > MS Excel
'
' ID:               Q_28233532
' Question Title:   Automate selection and paging process
' Question Asker:   Pedrov664                                 [ http://www.experts-exchange.com/M_6582434.html ]
' Question Dated:   2013-09-07 at 20:09:23
'
' Expert Comment:   fanpages                                   [ http://www.experts-exchange.com/M_258171.html ]
' Copyright:        (c) 2013 Clearlogic Concepts (UK) Limited                           [ http://NigelLee.info ]
' --------------------------------------------------------------------------------------------------------------

  Dim lngErr_Number                                     As Long
  Dim lngNumbers                                        As Long
  Dim objWorksheet                                      As Worksheet
  Dim strErr_Description                                As String
  Dim vntRange                                          As Variant
  
  On Error GoTo Err_Q_28233532
  
  Application.StatusBar = "Please wait..."
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  For Each objWorksheet In ThisWorkbook.Worksheets
  
      If Left$(objWorksheet.Name, 8) = "Numbers_" And _
         IsNumeric(Mid$(objWorksheet.Name, 9)) Then
         objWorksheet.Delete
      End If ' If Left$(objWorksheet.Name, 8) = "Numbers_" And IsNumeric(Mid$(objWorksheet.Name, 9)) Then

  Next objWorksheet
  
  Application.DisplayAlerts = True
  
  lngNumbers = 0&
  
  For Each vntRange In Array([B10:AG10], _
                             [B11:AG11], _
                             [B12:AG12], _
                             [B13:AG13], _
                             [B14:AG14], _
                             [B15:AG15], _
                             [B16:AG16], _
                             [B17:AG17], _
                             [B18:AG18], _
                             [B19:AG19])
                             
     lngNumbers = lngNumbers + 1&
     
     ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
     ActiveSheet.Name = "Numbers_" & CStr(lngNumbers)
                             
     Call CreateCombinations(Worksheets("Sheet1").Range(vntRange.Address), ActiveSheet.[A1], 5&)
     
  Next vntRange
  
Exit_Q_28233532:

  On Error Resume Next
  
  Set vntRange = Nothing
  Set objWorksheet = Nothing
  
  Worksheets("Sheet1").Select
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.StatusBar = False
  
  Beep
  
  Exit Sub
  
Err_Q_28233532:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description
  
  On Error Resume Next
  
  Application.ScreenUpdating = True
  
  Beep
  
  MsgBox "Error #" & CStr(lngErr_Number) & _
         vbCrLf & vbLf & _
         strErr_Description, _
         vbExclamation Or vbOKOnly, _
         ThisWorkbook.Name
         
  Resume Exit_Q_28233532
  
End Sub
Private Sub CreateCombinations(Optional ByRef rSrc As Range = Nothing, _
                               Optional ByRef rDst As Range = Nothing, _
                               Optional ByVal nDim As Long = 0&)                    ' *** [16/09/2013]: Added three parameters
' keepITcool 2004/11/01
' [16/09/2013]: fanpages
    
'   Dim rSrc As Range                                                               ' *** [16/09/2013]: Removed
'   Dim rDst As Range                                                               ' *** [16/09/2013]: Removed
    Dim rITM As Range
    Dim cItm As Collection, vItm()
    Dim aIdx() As Byte, vRes()
'   Dim nDim&                                                                       ' *** [16/09/2013]: Removed
    Dim nItm&, nCnt&
    Dim r&, c&
    
  If (rSrc Is Nothing) Then                                                         ' *** [16/09/2013]: Added
     Set rSrc = Application.InputBox("Select the Source data", Type:=8)
     If rSrc Is Nothing Then
        Beep
        Exit Sub
     End If
  End If ' If (rSrc Is Nothing) Then                                                ' *** [16/09/2013]: Added
  
    'Create a collection of unique items in range.
    Set cItm = New Collection
    On Error Resume Next
    For Each rITM In rSrc.Cells
        If rITM <> vbNullString Then cItm.Add rITM.Value2, CStr(rITM.Value2)
    Next
    nItm = cItm.Count
    ReDim vItm(1 To nItm)
    For r = 1 To nItm
        vItm(r) = cItm(r)
    Next
    On Error GoTo 0
    
  If nDim = 0& Then                                                                 ' *** [16/09/2013]: Added
     Let nDim = Application.InputBox("Size of 'groups' ", Type:=1)
     If nDim < 1 Or nDim > nItm Then
        Beep
        Exit Sub
     End If
  End If ' If nDim = 0& Then                                                        ' *** [16/09/2013]: Added
    
    'Get the number of combinations
    nCnt = Application.Combin(nItm, nDim)
    If nCnt > Rows.Count Then
        MsgBox nCnt & " combinations...Wont fit  ", vbCritical
    'Exit Sub
    End If
    'Create the index array
    ReDim aIdx(0 To 2, 1 To nDim) As Byte
    'Create the result array
    ReDim vRes(1 To nCnt, 1 To nDim)
    'min on first row, max on last row
    
    For c = 1 To nDim
        aIdx(0, c) = c
        aIdx(2, c) = nItm - nDim + c
        vRes(1, c) = vItm(aIdx(0, c))
        vRes(nCnt, c) = vItm(aIdx(2, c))
    Next
    
    
    For r = 2 To nCnt - 1
        aIdx(1, nDim) = aIdx(0, nDim) + 1
        For c = 1 To nDim - 1
            If aIdx(0, c + 1) = aIdx(2, c + 1) Then
                aIdx(1, c) = aIdx(0, c) + 1
            Else
                aIdx(1, c) = aIdx(0, c)
            End If
        Next
        For c = 2 To nDim
            If aIdx(1, c) > aIdx(2, c) Then
                aIdx(1, c) = aIdx(1, c - 1) + 1
            End If
        Next
        For c = 1 To nDim
            aIdx(0, c) = aIdx(1, c)
            vRes(r, c) = vItm(aIdx(1, c))
        Next
    Next
    
    
dump:
  If (rDst Is Nothing) Then                                                         ' *** [16/09/2013]: Added
     Set rDst = Application.InputBox("Select the Destination Range", Type:=8)
     If rDst Is Nothing Then
        Beep
        Exit Sub
     End If
  End If ' If (rDst Is Nothing) Then                                                ' *** [16/09/2013]: Added
  
    If Rows.Count - rDst.Row < nCnt Then
        Stop
    ElseIf Columns.Count - rDst.Column < nDim Then
        Stop
    End If
    With rDst
        .CurrentRegion.Clear
        .Resize(nCnt, nDim) = vRes
    End With

End Sub

Open in new window



When you open the workbook, please use the [ALT]+[F8] key combination to display the "Macro" dialog box, select "Q_28233532" as the "Macro name", & click the [Run] button.

Thank you for your feedback when you have had the opportunity to review the code/output generated.

BFN,

fp.
Q-28233532.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Pedrov664Author Commented:
After running the code it displays error:

Compile error:

Ambiguous name detected: CreateCombinations

and highlights the following:

Private Sub CreateCombinations(Optional ByRef rSrc As Range = Nothing, _
                               Optional ByRef rDst As Range = Nothing, _
                               Optional ByVal nDim As Long = 0&)  

Do I need to change the name of anything to march so I do not get this error?
0
[ fanpages ]IT Services ConsultantCommented:
I am guessing that you have copied the code from my workbook  (attached above), to your own workbook (where the CreateCombinations() subroutine is already present within the "Module1" code module).

Please ensure that the CreateCombinations() subroutine within the "basQ_28233532" code module is the only Public subroutine of that name in the VBProject.

If CreateCombinations() is the only subroutine or function within "Module1", simply delete that code module.
0
Pedrov664Author Commented:
fanpages,

Once again you saved the day. After running it as you intended it works as planned.

Thank you very much for all your time and effort!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.