Create records

[Jaye7]

I have a list of values in column A/ Serial1, I have a list of values in Column E/ Name.

What I want to do is have the records populate like the 2 last columns NAMED OUTPUT SERIAL 1 AND OUTPUT NAME, so for each record in the name column it will have the serial next to it.
Sorry I didn't know how to explain it better, hopefully the example will help.

This is just an example, there are thousands of records to process.

It would be good if I could have an inputbox to ask which column holds the serial1 data and which column holds the name data, just in case the data is entered in a different column.
There are values in columns B to D but it is not required in the output.

I am using excel 2007 and 2010.

SERIAL 1 NAME OUTPUT SERIAL 1 OUTPUT NAME 124 80000 124 8000 635 82004 124 80000 925 820603 124 82004 734 7772526 124 820603 1200 36873 124 7772526 873873 124 36873 87387 124 873873 543 124 87387 8736 124 543 213131 124 8736 876 124 213131 888756 124 876 87 124 888756 124 87 635 8000 635 80000 635 82004 635 820603 635 7772526 635 36873 635 873873 635 87387 635 543 635 8736 635 213131 635 876 635 888756 635 87 <tbody> </tbody>

<tbody>
</tbody>

 

[hiker95]

Jaye7,

The following macro will search the active worksheet, row 1, for the titles SERIAL 1, and, NAME.

If it does not find both titles in row 1, you will receive a message to that fact, and, the macro will terminate.

Sample raw data:

Excel 2007
	A	B	C	D	E	F	G	H
1		SERIAL 1		NAME
2		124		80000
3		635		82004
4		925		820603
5		734		7772526
6		1200		36873
7				873873
8				87387
9				543
10				8736
11				213131
12				876
13				888756
14				87
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Sheet1

After the macro using three arrays in memory:

Excel 2007
	A	B	C	D	E	F	G	H
1		SERIAL 1		NAME			OUTPUT SERIAL 1	OUTPUT NAME
2		124		80000			124	80000
3		635		82004			124	82004
4		925		820603			124	820603
5		734		7772526			124	7772526
6		1200		36873			124	36873
7				873873			124	873873
8				87387			124	87387
9				543			124	543
10				8736			124	8736
11				213131			124	213131
12				876			124	876
13				888756			124	888756
14				87			124	87
15
16							635	80000
17							635	82004
18							635	820603
19							635	7772526
20							635	36873
21							635	873873
22							635	87387
23							635	543
24							635	8736
25							635	213131
26							635	876
27							635	888756
28							635	87
29
30							925	80000
31							925	82004
32							925	820603
33							925	7772526
34							925	36873
35							925	873873
36							925	87387
37							925	543
38							925	8736
39							925	213131
40							925	876
41							925	888756
42							925	87
43
44							734	80000
45							734	82004
46							734	820603
47							734	7772526
48							734	36873
49							734	873873
50							734	87387
51							734	543
52							734	8736
53							734	213131
54							734	876
55							734	888756
56							734	87
57
58							1200	80000
59							1200	82004
60							1200	820603
61							1200	7772526
62							1200	36873
63							1200	873873
64							1200	87387
65							1200	543
66							1200	8736
67							1200	213131
68							1200	876
69							1200	888756
70							1200	87
71
Sheet1

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).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub CreateRecords()
' hiker95, 09/19/2014, ME806514
Dim s As Variant, n As Variant, o As Variant
Dim i As Long, j As Long, k As Long
Dim lrs As Long, lrn As Long, lc As Long, nlr As Long
Dim sn As Range, na As Range
lc = Cells(1, Columns.Count).End(xlToLeft).Column
Set sn = Rows(1).Find("SERIAL 1", LookAt:=xlWhole)
Set na = Rows(1).Find("NAME", LookAt:=xlWhole)
If (Not sn Is Nothing) * (Not na Is Nothing) Then
  Application.ScreenUpdating = False
  lrs = Cells(Rows.Count, sn.Column).End(xlUp).Row
  s = Range(Cells(1, sn.Column), Cells(lrs, sn.Column))
  lrn = Cells(Rows.Count, na.Column).End(xlUp).Row
  n = Range(Cells(1, na.Column), Cells(lrn, na.Column))
  nlr = (lrs * 2) * lrn
  ReDim o(1 To nlr, 1 To 2)
Else
  MsgBox "One, or, both titles 'SERIAL 1' 'NAME' were not found in row 1 - macro terminated!"
  Exit Sub
End If
k = k + 1
o(k, 1) = "OUTPUT SERIAL 1"
o(k, 2) = "OUTPUT NAME"
For i = 2 To lrs Step 1
  For j = 2 To lrn Step 1
    k = k + 1
    o(k, 1) = s(i, 1)
    o(k, 2) = n(j, 1)
  Next j
  k = k + 1
Next i
Cells(1, lc + 3).Resize(nlr, 2).Value = o
Columns(lc + 3).Resize(, 2).AutoFit
Application.ScreenUpdating = True
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 CreateRecords macro.

 

[Jaye7]

Great code, thanks very much.
Sorry I should have specified why I wanted the input box for the columns, the reason is that the names may change, are you able to help with this?.

 

[hiker95]

Jaye7,

Great code, thanks very much.

Thanks for the feedback.

You are very welcome. Glad I could help.

It would be good if I could have an inputbox to ask which column holds the serial1 data and which column holds the name data, just in case the data is entered in a different column.

I can do the above.

1. Can I have some examples of what the two column titles could be for testing purposes?

2. What row in the worksheet will contain the two column titles?

3. The two results columns, OUTPUT SERIAL 1, and, OUTPUT NAME, will be placed beginning in the third column after the last used column in the worksheet. Is that acceptable?

 

[Jaye7]

Hi Hiker95.

The first column could be named PDescription or LNum, Second Column Could Be Named PNumber Or LDecim.
Row 1 would always have the Titles.
The output column in the 3rd empty column after the last column would be great.

 

[hiker95]

Jaye7,

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).

1. Copy the below macro code including the code line Option Compare Text
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Compare Text
Sub CreateRecords_V2()
' hiker95, 09/19/2014, ME806514
Dim s As Variant, n As Variant, o As Variant
Dim i As Long, j As Long, k As Long
Dim lrs As Long, lrn As Long, lc As Long, nlr As Long
Dim sn As Range, na As Range
Dim InSerial As String, InName As String
InSerial = InputBox("What is the column title for the 'Serial' data?")
InName = InputBox("What is the column title for the 'Name' data?")
If InSerial = "" Or InName = "" Then
  MsgBox "One, or, both titles '" & InSerial & "'  '" & InName & "' were not found in row 1 - macro terminated!"
  Exit Sub
End If
lc = Cells(1, Columns.Count).End(xlToLeft).Column
Set sn = Rows(1).Find(InSerial, LookAt:=xlWhole)
Set na = Rows(1).Find(InName, LookAt:=xlWhole)
If (Not sn Is Nothing) * (Not na Is Nothing) Then
  Application.ScreenUpdating = False
  lrs = Cells(Rows.Count, sn.Column).End(xlUp).Row
  s = Range(Cells(1, sn.Column), Cells(lrs, sn.Column))
  lrn = Cells(Rows.Count, na.Column).End(xlUp).Row
  n = Range(Cells(1, na.Column), Cells(lrn, na.Column))
  nlr = (lrs * 2) * lrn
  ReDim o(1 To nlr, 1 To 2)
Else
  MsgBox "One, or, both titles '" & InSerial & "'  '" & InName & "' were not found in row 1 - macro terminated!"
  Exit Sub
End If
k = k + 1
o(k, 1) = "OUTPUT SERIAL 1"
o(k, 2) = "OUTPUT NAME"
For i = 2 To lrs Step 1
  For j = 2 To lrn Step 1
    k = k + 1
    o(k, 1) = s(i, 1)
    o(k, 2) = n(j, 1)
  Next j
  k = k + 1
Next i
Cells(1, lc + 3).Resize(nlr, 2).Value = o
Columns(lc + 3).Resize(, 2).AutoFit
Application.ScreenUpdating = True
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 CreateRecords_V2 macro.

 

[Jaye7]

It does work, sorry to be a pain, but rather than having to type in the names of the fields (as the descriptions can be very long) are you able to change the input to just the column references, i.e. you just type column A or B or C etc... (for first column field name) and E or F or G (for second column field name).

 

[hiker95]

Jaye7,

1. Please explain in detail the purpose of/for this project/exercise?

2. Is this a homework assignment?

 

[Jaye7]

Hi Hiker95, haha, no I am a bit old for homework, just a function that someone asked me for at work and I didn't have one in my bank of scripts.

 

[hiker95]

Jaye7,

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).

Sub CreateRecords_V3()
' hiker95, 09/20/2014, ME806514
Dim s As Variant, n As Variant, o As Variant
Dim i As Long, j As Long, k As Long
Dim lrs As Long, lrn As Long, lc As Long, nlr As Long
Dim ss As String, sn As String
Dim ns As Long, nn As Long
ss = InputBox("What is the column reference 'A, B, C....' for the 'Serial' data?")
sn = InputBox("What is the column reference 'A, B, C....' for the 'Name' data?")
ns = Asc(UCase(ss)) - 64
nn = Asc(UCase(sn)) - 64
lc = Cells(1, Columns.Count).End(xlToLeft).Column
lrs = Cells(Rows.Count, ns).End(xlUp).Row
lrn = Cells(Rows.Count, nn).End(xlUp).Row
If lrs <= 1 Or lrn <= 1 Then
  MsgBox "One, or, both columns '" & ss & "' or '" & sn & "' were blank - macro terminated!"
  Exit Sub
End If
Application.ScreenUpdating = False
s = Range(Cells(1, ns), Cells(lrs, ns))
n = Range(Cells(1, nn), Cells(lrn, nn))
nlr = (lrs * 2) * lrn
ReDim o(1 To nlr, 1 To 2)
k = k + 1
o(k, 1) = "OUTPUT SERIAL 1"
o(k, 2) = "OUTPUT NAME"
For i = 2 To lrs Step 1
  For j = 2 To lrn Step 1
    k = k + 1
    o(k, 1) = s(i, 1)
    o(k, 2) = n(j, 1)
  Next j
  k = k + 1
Next i
Cells(1, lc + 3).Resize(nlr, 2).Value = o
Columns(lc + 3).Resize(, 2).AutoFit
Application.ScreenUpdating = True
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 CreateRecords_V3 macro.