Permutation Combination using Macro

[Hkkc]

Hi All,

I'm very new to the macro world and at the moment struggling to write macro to create the desired out put as in the attached spreadsheet. The "Input Data" will be used to create the desired result in "Expected". The "Input Data" "Columns" and "Rows" can change meaning it can increase / reduce as per different requirement and it is possible to insert a column in between.

Given all the above conditions a new spreadsheet should be created as shown in the "Expected".

Column A2 data should be repeated for the number of unique times the data in Column B2 and it has be in pair as shown in the "Expected" Sheet. This is applicable for all the column values that is shown in the "Input Data" Sheet.

The macro should be capable of covering all the possible combinations in pairs again as shown in "Expected" sheet.

Please let me know if you require more information.

Thanks
Hkkc

[reyreyreyes]

Hi Hkkc, I know you said you are new, but have you done anything so far? The file attached is completely empty of any code, despite being macro enabled.

On your 'Expected' tab, you have multiple 'Browsers' 'Device' etc. columns, yet you stated "a new spreadsheet should be created". Are you just wanting a button that copies and pastes the table on the 'Input Data' tab to copy the entries into a new sheet each time? That would not look like what's in 'Expected', as you'd always only have one set of data on each sheet.

Or, I've misunderstood!

[Paul_Hossler]

Try this





Option Explicit
Dim wsData As Worksheet, wsExp As Worksheet

Sub Perm()
Set wsData = Worksheets("Input Data")
Application.ScreenUpdating = False

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Expected").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Worksheets.Add.Name = "Expected"
Set wsExp = Worksheets("Expected")

' 1 2 3 4
'Browsers Device OS Region
Call PermSub(1, 2, 1)
Call PermSub(2, 3, 4)
Call PermSub(3, 4, 7)
Call PermSub(1, 3, 10)
Call PermSub(2, 4, 13)
Call PermSub(1, 4, 16)
Application.ScreenUpdating = True
End Sub


Private Sub PermSub(InCol1 As Long, InCol2 As Long, OutCol As Long)
Dim i As Long, j As Long, OutRow As Long
Dim R1 As Range, R2 As Range

With wsData
Set R1 = Range(.Cells(1, InCol1), .Cells(1, InCol1).End(xlDown))
Set R2 = Range(.Cells(1, InCol2), .Cells(1, InCol2).End(xlDown))
End With

OutRow = 2
wsExp.Cells(OutRow, OutCol).Value = R1.Cells(1, 1).Value
wsExp.Cells(OutRow, OutCol + 1).Value = R2.Cells(1, 1).Value


For i = 2 To R1.Rows.Count
For j = 2 To R2.Rows.Count
OutRow = OutRow + 1
wsExp.Cells(OutRow, OutCol).Value = R1.Cells(i, 1).Value
wsExp.Cells(OutRow, OutCol + 1).Value = R2.Cells(j, 1).Value
Next j
Next i
End Sub

[Hkkc]

Hi Reyreyreyes, I didn't try anything. But started to go through the beginners lessons. The spreadsheet was part of my learning and I posted the same here without changing it to .xlsx.

The Expected is what I actually want to see as a output of the macro. The Macro will create a new spreadsheet lets call it as "Pair Combinations" (as the "Expected" shows data paired). The spreadsheet will have only one worksheet "Input Data" and from there I have to run the macro to generate the "Pair Combinations" and the results should be shown as in the "Expected". It need not create multiple sheets. The set of data is for understanding purpose and the real data will change, may have more columns and rows added to it.

Column A2 data should be repeated for the number of unique times the data in Column B2 and it has be in pair as shown in the "Expected" Sheet. This is applicable for all the column values that is shown in the "Input Data" Sheet. This should not be unique set of data.

Hope I have made some sense, if not please don't hesitate to ask more questions

Thanks,
Hkkc

[Hkkc]

Hi Paul, This is working fine only for the first four columns, as stated earlier we can expect more columns and rows added anywhere in the input data sheet. We cannot stick to 4 columns. Could you please include that scenario also.

Thanks,
Hkkc

[Paul_Hossler]

Option Explicit
Dim wsData As Worksheet, wsExp As Worksheet

Sub Perm()
Dim field1 As Long, field2 As Long, o As Long
Dim rInput As Range

Application.ScreenUpdating = False

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Expected").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Worksheets.Add.Name = "Expected"
Set wsExp = Worksheets("Expected")

Set wsData = Worksheets("Input Data")
Set rInput = wsData.Cells(1, 1).CurrentRegion

o = 1
For field1 = 1 To rInput.Columns.Count - 1
For field2 = field1 + 1 To rInput.Columns.Count
Call PermSub(field1, field2, o)
o = o + 3
Next field2
Next field1
Application.ScreenUpdating = True
End Sub
Private Sub PermSub(InCol1 As Long, InCol2 As Long, OutCol As Long)
Dim i As Long, j As Long, OutRow As Long
Dim R1 As Range, R2 As Range

With wsData
Set R1 = Range(.Cells(1, InCol1), .Cells(1, InCol1).End(xlDown))
Set R2 = Range(.Cells(1, InCol2), .Cells(1, InCol2).End(xlDown))
End With

OutRow = 2
wsExp.Cells(OutRow, OutCol).Value = R1.Cells(1, 1).Value
wsExp.Cells(OutRow, OutCol + 1).Value = R2.Cells(1, 1).Value


For i = 2 To R1.Rows.Count
For j = 2 To R2.Rows.Count
OutRow = OutRow + 1
wsExp.Cells(OutRow, OutCol).Value = R1.Cells(i, 1).Value
wsExp.Cells(OutRow, OutCol + 1).Value = R2.Cells(j, 1).Value
Next j
Next i
End Sub

[Hkkc]

Hi Paul, Amazing. Thanks a lot buddy. It worked except for when you add a row above the heading which I think is fine. Thanks a ton!

[Paul_Hossler]

Hi Paul, Amazing. Thanks a lot buddy. It worked except for when you add a row above the heading which I think is fine. Thanks a ton!

I followed your example

Adding a row above which heading?

[Hkkc]

Hi Paul, I'm happy that you were able to help me. I will add that as a mandate to start the input data from A1 and not from A3 or A4.

[Paul_Hossler]

Hi Paul, I'm happy that you were able to help me. I will add that as a mandate to start the input data from A1 and not from A3 or A4.

It's easy enough to start the input data block on the first row with data

Let me know