I've 2 sets of data, A and B as shown below.

enter image description here

What I want to do is to combine data A and B to produce data C.

Is there a way to automate this instead of manual copy and paste?

What is the best solution to do this as the actual data is huge.

  • If you are expecting IP to repeat 3 times then Policy & Description will be repeated also the expected out put is an odd combination,, you may refer my post – Rajesh S Mar 26 at 10:21

Try this code in a module and linked to a button on the page, it assumes your IP addresses are in A, Policy in C and description in D. Output goes to columns F,G and H.

Sub matrix()

Application.ScreenUpdating = False
Dim ws1 As Worksheet: Set ws1 = Sheet1
Dim MyIPRnge As Range, MyPRnge As Range, MyDRnge As Range
Dim MyX As String
Dim MyArr() As Variant
Dim i As Long, x As Long, y As Long, MyCols As Long

Set MyIPRnge = ws1.Range(ws1.Cells(2, 1), ws1.Cells(ws1.Cells(2, 1).End(xlDown).Row, 1))
Set MyPRnge = ws1.Range(ws1.Cells(2, 3), ws1.Cells(ws1.Cells(2, 3).End(xlDown).Row, 3))
Set MyDRnge = ws1.Range(ws1.Cells(2, 4), ws1.Cells(ws1.Cells(2, 4).End(xlDown).Row, 4))
MyCols = ws1.Cells(2, 3).End(xlToRight).Column - 2 ' the two assumes it is in column 3 to start with, modify to 1 less than start col
ReDim MyArr(MyIPRnge.Rows.Count * MyPRnge.Rows.Count)
x = 1
For i = LBound(MyArr) To UBound(MyArr) - 1
    MyArr(i) = MyPRnge(x, 1)
    If x = MyPRnge.Rows.Count Then
    x = 1
    x = x + 1
    End If
Next i
ws1.Range(ws1.Cells(2, 7), ws1.Cells((MyIPRnge.Rows.Count * MyPRnge.Rows.Count) + 1, 8)) = Application.Transpose(MyArr)
x = 1
For i = LBound(MyArr) To UBound(MyArr) - 1
    MyArr(i) = MyDRnge(x, 1)
    If x = MyDRnge.Rows.Count Then
    x = 1
    x = x + 1
    End If
Next i
ws1.Range(ws1.Cells(2, 8), ws1.Cells((MyIPRnge.Rows.Count * MyPRnge.Rows.Count) + 1, 8)) = Application.Transpose(MyArr)
ReDim MyArr(MyIPRnge.Rows.Count)
MyArr = MyIPRnge.Value2
y = 1
For i = 1 To UBound(MyArr) * MyPRnge.Rows.Count Step UBound(MyArr)
    For x = 1 To UBound(MyArr)
        ws1.Range(ws1.Cells(x + i, 6), ws1.Cells(UBound(MyArr) + i, 6)) = MyArr(y, 1)
    Next x
    y = y + 1
Next i

End Sub
|improve this answer|||||

It looks like you want to combine the data from Data B with every row from Data A

The code below assumes:

  • Data A is a Table on Sheet1 named DataA and has a single column.
  • Data B is a Table on Sheet1 named DataB and can have multiple columns.
  • The Output is going on the same worksheet, but you can easily alter the code to put it elsewhere.

If the data is not in tables, you can easily use a different algorithm to find them.

Since the code does the "work" in VBA arrays, dictionary and collection, if your data is sizeable, you should see a noticeable speed difference compared with read/writing to/from the worksheet.

The code should auto-adjust if you add more rows to either table, or more columns to DataB

Option Explicit
Sub combineTables()
    Dim loA As ListObject, loB As ListObject
    Dim dataA As Variant, dataB As Variant
    Dim ws As Worksheet
    Dim I As Long, J As Long, K As Long, V, W, X
    Dim myD As Dictionary, Col As Collection
    Dim sKey As String

    Dim vRes As Variant, wsRes As Worksheet, rRes As Range

'Read the data into variant arrays for processing speed
Set ws = ThisWorkbook.Worksheets("Sheet1") 'or whatever

Set loA = ws.ListObjects("DataA")
Set loB = ws.ListObjects("DataB")

dataA = loA.DataBodyRange
dataB = loB.DataBodyRange

'Write the combinations into a dictionary to organize it
Set myD = New Dictionary

For I = 1 To UBound(dataA)
    Set Col = New Collection
    sKey = dataA(I, 1)
    myD.Add Key:=sKey, Item:=Col
        For J = 1 To UBound(dataB)
            ReDim V(1 To UBound(dataB, 2))
            For K = 1 To UBound(V)
                V(K) = dataB(J, K)
            Next K
            myD(sKey).Add V
        Next J
Next I

'Output the results into an array
ReDim vRes(0 To UBound(dataA) * UBound(dataB), 1 To UBound(dataA, 2) + UBound(dataB, 2))

vRes(0, 1) = "IP"

For J = 1 To loB.HeaderRowRange.Columns.Count
    vRes(0, J + 1) = loB.HeaderRowRange.Columns(J).Value
Next J

I = 0
For Each V In myD.Keys
    For Each W In myD(V)
        J = 1
        I = I + 1
        vRes(I, J) = V
        For Each X In W
            J = J + 1
            vRes(I, J) = X
        Next X
    Next W
Next V

'write to the worksheet
Set wsRes = ws
Set rRes = wsRes.Cells(1, 10)
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))

With rRes
    .Value = vRes
    .Style = "Output"
End With

End Sub

enter image description here

|improve this answer|||||

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.