How to create a Macro which forms new list combining elements of ColA with ColB

[LisaDavis]

I want to combine approx 100 items in column A with around 200 items in column B without having to do it by manually copying and pasting.

Below is a simplified version of what I am trying to do. Can I do this with a Macro?

A1	B1
A2	B2
A3	B3

<TBODY>
</TBODY>

A1	B1
A1	B2
A1	B3
A2	B1
A2	B2
A2	B3
A3	B1
A3	B2
A3	B3

<TBODY>
</TBODY>

 

[mumps]

Hi Lisa. Try this macro. The new list will be copied to Sheet2.

Sub Test()
    Application.ScreenUpdating = False
    Dim x As Long
    Dim bottomB As Long
    bottomB = Range("B" & Rows.Count).End(xlUp).Row
    Dim rng As Range
    For Each rng In Range("A1:A" & bottomB)
        For x = 1 To bottomB
            rng.Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            Cells(x, 2).Copy Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
        Next x
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[hippiehacker]

this should do

Sub lisdavis()
Dim Arr1() As Variant, Arr2 as Variant ' declare an unallocated array.
Arr1 = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value ' Arr is now an allocated array
Arr2 = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row).Value ' Arr is now an allocated array
For j = 1 To UBound(Arr1)
For i = 1 To UBound(Arr2)
 k = k + 1
 Cells(k, 1) = Arr1(j, 1)
 Cells(k, 2) = Arr1(i, 1)
Next i
Next j
End Sub

 

[LisaDavis]

Thank you so much. When I tried the code it worked perfectly for a relatively small amount of data, but when I had 100 (or even just 5 or 10) elements in the first column with 202 in the 2nd Excel kept locking up on me for long periods of time. I tried yours and the response from below and in this particular case the one below seemed to work better (although it does not put the new data on a separate sheet - and therefore overrides the original), but I have saved both and will fully take advantage of these while I am creating some pretty complicated spreadsheets!

Thanks again. Great advise!

 

[LisaDavis]

Thank you! This worked perfectly for what i needed to do today!

 

[hippiehacker]

there was never a word about to put the data into a new sheet??? this can be done just easily if required?

 

[LisaDavis]

The way you helped me solve this works fine for what I am doing. I had already copied the two unique columns to another worksheet so it wasn't an issue here. If it is an easy fix I would love to know how to do it. I am very proficient with almost all aspects of Excel but am just beginning to really take on Macros and VBA.

Also, can you tell by looking at the code from mumps why it would work relatively well with small amounts of data (say 10 in column A and 10 in column B) but not once one or both columns started to include larger amounts of data (say 5 in column A and 202 in column B)? I am hoping to learn for my own benefit going forward

Thanks again for your help!

 

[hippiehacker]

new code will place the results in a new sheet called result

Sub lisdavis()
Dim Arr1() As Variant, Arr2 As Variant ' declare an unallocated array.
Set aws = ActiveSheet
Arr1 = aws.Range("A1:A" & aws.Range("A" & Rows.Count).End(xlUp).Row).Value ' Arr is now an allocated array
Arr2 = aws.Range("B1:B" & aws.Range("B" & Rows.Count).End(xlUp).Row).Value ' Arr is now an allocated array
Sheets.Add.Name = "Result"
Set nws = Sheets("Result")
For j = 1 To UBound(Arr1)
For i = 1 To UBound(Arr2)
 k = k + 1
 nws.Cells(k, 1) = Arr1(j, 1)
 nws.Cells(k, 2) = Arr2(i, 1)
Next i
Next j
End Sub

the problem with mumps code I see on several points

1. his looping is wrong - its catching only lastrow in ColB even if there is nothing in ColA it will continue the loop until row ColB has been reached say Col A hosts 3 values ColB 10 it should write 30 in total but It will write now around 300
2. the copy data is taking a lot of time

i just slightly corrected the code

Sub Test()
    Application.ScreenUpdating = False
    Dim x As Long
    Dim bottomB As Long
    bottomB = Range("B" & Rows.Count).End(xlUp).Row
    Dim rng As Range
    For Each rng In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        For x = 1 To bottomB
            Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = rng.Value
            Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Value = Cells(x, 2).Value
        Next x
    Next rng
    Application.ScreenUpdating = True
End Sub

it should work as well

 

[hiker95]

LisaDavis,

With the numbers 1 thru 100 in column A, beginning in cell A1.

And, with the numbers 1 thru 200 in column B, beginning in cell B1.

The below macro (using three arrays in memory) will create the 20,000 pairs of numbers, and, write them to columns D:E with a runtime of 0.063 seconds.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub CreateNewList()
Dim a As Variant, b As Variant, o As Variant
Dim i As Long, ii As Long, iii As Long
a = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
b = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
ReDim o(1 To UBound(a, 1) * UBound(b, 1), 1 To 2)
For i = 1 To UBound(a, 1)
  For ii = 1 To UBound(b, 1)
    iii = iii + 1
    o(iii, 1) = a(i, 1)
    o(iii, 2) = b(ii, 1)
  Next ii
Next i
Columns("D:E").ClearContents
Range("D1").Resize(UBound(o, 1), UBound(o, 2)) = o
Columns("D:E").AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the CreateNewList macro.

 

[hiker95]

LisaDavis,

I am very proficient with almost all aspects of Excel but am just beginning to really take on Macros and VBA.

See if something in my most up to date list will help you:

Training / Books / Sites as of 1/30/2014
http://www.mrexcel.com/forum/excel-...umber-statement-end-statment.html#post3706277