Macro to create duplicate rows based on the value of particular fields

[EmicoCP]

I need to create a macro that allows me to: 1) create duplicate rows based on the value "x" being present in a set of columns 2) once created, remove those referenced columns and replace with a specific word
Country | Hot | Cold | Windy | Icey
England today is | | x | x | |
Should yield 2 records taking the new field value from the column heading above:
Country | Weather type |
England today is | Cold |
England today is | Windy |
I hope this makes sense and would be extremely grateful for any guidance.
NB: I have researched this but can only see questions slightly similar but not quite i.e. those which have a count instead of an "x".

 

[hiker95]

EmicoCP,

Welcome to the MrExcel forum.

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?


If the raw data worksheet name is NOT Sheet1 then we can change it in the macro.

The following macro will adjust to the varying number of rows, and, columns for your raw data, and, the output will begin in the third column to the right of the last used title in row 1.

Sample raw data in worksheet Sheet1:

Excel 2007
	A	B	C	D	E	F	G	H	I
1	Country	Hot	Cold	Windy	Icey
2	England today is		x	x
3
4
Sheet1

After the macro using two arrays in memory:

Excel 2007
	A	B	C	D	E	F	G	H	I
1	Country	Hot	Cold	Windy	Icey			Country	Weather type
2	England today is		x	x				England today is	Cold
3								England today is	Windy
4
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 CreateDuplicateRows()
' hiker95, 02/21/2015, ME837663
Dim a As Variant, o As Variant
Dim i As Long, j As Long
Dim lr As Long, lc As Long, luc As Long, c As Long, n As Long
With Sheets("Sheet1")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, 1).End(xlToRight).Column
  luc = .Cells(1, Columns.Count).End(xlToLeft).Column
  If luc > lc Then
    n = luc - (lc + 2)
    .Columns(lc + 3).Resize(, n).ClearContents
  End If
  .Cells(1, lc + 3).Resize(, 2).Value = Array("Country", "Weather type")
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = Application.CountA(.Range(.Cells(2, 2), .Cells(lr, lc)))
  ReDim o(1 To n, 1 To 2)
  For i = 2 To UBound(a, 1)
    For c = 2 To UBound(a, 2)
      If a(i, c) <> "" Then
        j = j + 1
        o(j, 1) = a(i, 1)
        o(j, 2) = a(1, c)
      End If
    Next c
  Next i
  .Cells(2, lc + 3).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(lc + 3).Resize(, 2).AutoFit
End With
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, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the CreateDuplicateRows macro.

 

[EmicoCP]

Hello hiker95,

First of all, thank you. You've definitely made me feel welcome to this forum. You replied very swiftly. You've been very clear in your instructions and have given me a great starting point. Again, thank you!

So, I was able to run the code with the example successfully however, my "real world" data set is slightly different to the above. I have columns before and after the "x" columns so when I run your macro against that, I get new records for all columns which have any value in them. Can we tweak the code in a way that:

1) renders the data in a new worksheet; and
2) retains all column entries on each side of the "x columns" so you basically end up with duplicate rows bar the new "Weather type" value e.g.


Country | Observation | Weather type | Season | Population
England today is | Generally | Cold | Spring | 200M
England today is | Overall | Windy | Spring | 200M

 

[EmicoCP]

Much has been made about "doing your own research" so, I've tried to deconstruct your code to better understand it but unfortunately, it just demonstrates my lack of knowledge in this space. From RemDim onwards I'm pretty much lost!

lr = .Cells(Rows.Count, 1).End(xlUp).Row 'is used to count how many rows that contains data in the first column?
lc = .Cells(1, 1).End(xlToRight).Column 'is used to find the last cell in the first column?
luc = .Cells(1, Columns.Count).End(xlToLeft).Column 'is used to find the last non-blank column number?
If luc > lc Then 'comparies the last non-blank column number to the last non-blank column in the first row basically to give you the entire data range?
n = luc - (lc + 2) 'if luc is larger than lc, n becomes the value of the right most column in the range + two for the purpose of storing the newly generated data range
.Columns(lc + 3).Resize(, n).ClearContents 'gets the value ready for the new data to be pasted in?
End If 'i guess the above section is a way of getting the entire range and this segment below tells it where to put the cells
.Cells(1, lc + 3).Resize(, 2).Value = Array("Country", "Weather Type") 'adds column headers? with the resize giving us 2 columns - I guess this is where I need the entire row
a = .Range(.Cells(1, 1), .Cells(lr, lc)) 'selects the entire range?
n = Application.CountA(.Range(.Cells(2, 2), .Cells(lr, lc))) 'counts the number of non-empty cells in the range but not sure about the first cells call (2,2)
ReDim o(1 To n, 1 To 2) 'moves cell values to the new column headings above?
For i = 2 To UBound(a, 1) 'returns an upper value for the copie range?
For c = 2 To UBound(a, 2)
If a(i, c) <> "" Then 'not sure

 

[EmicoCP]

Also, I'm using Excel 2010 and Windows 8.1

 

[hiker95]

EmicoCP,

First of all, thank you. You've definitely made me feel welcome to this forum. You replied very swiftly. You've been very clear in your instructions and have given me a great starting point. Again, thank you!

Thanks for the feedback.

You are very welcome. Glad I could help.

Can we tweak the code in a way that:

1) renders the data in a new worksheet; and
2) retains all column entries on each side of the "x columns" so you basically end up with duplicate rows bar the new "Weather type" value e.g.

1. What is the correct raw data worksheet name?

2. Do you have a preference for the new worksheet name?


So that we can get it right on the next try:

Can you post a screenshot of the actual raw data worksheet?

And, can you post a screenshot of the worksheet results (manually formatted by you) that you are looking for?

To post a small screen shot (NOT a graphic, or, picture) try one of the following:

Excel Jeanie
Download

MrExcel HTML Maker
https://onedrive.live.com/?cid=8cffdec0ce27e813&sc=documents&id=8CFFDEC0CE27E813!189

Borders-Copy-Paste
http://www.mrexcel.com/forum/about-board/444901-how-create-table-like-aladin.html#post2198045

To test the above:
Test Here


Or, you can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.

 

[EmicoCP]

Hi Hiker95,

I've created a version of the data in the file here: http://1drv.ms/1zxO4Vn

The first worksheet is an example of the data (field names are accurate) with sensitive data changed.

The second worksheet is an example of what the correct output would be if the first 3 records from the first worksheet were "atomised" as described above in essence resulting in 5 records.

The worksheets are named as required.

You'll notice columns I-N from the first worksheet are replaced with a single column (I) in the second.

Thank you for your time here.

 

[hiker95]

EmicoCP,

Thanks for the link.

I am not able to download the workbook.

I am not able to copy the data from the two worksheets.


Please use the following free site:

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.

 

[EmicoCP]

EmicoCP,

Thanks for the link.

I am not able to download the workbook.

I am not able to copy the data from the two worksheets.


Please use the following free site:

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.

Here you go: https://app.box.com/s/o60koacz3p8twm6ipujf3pk04ffu282w

 

[hiker95]

EmicoCP,

Thanks for the new workbook.

What a HUGE difference from your original reply #1.

I assume that both worksheets exist, and, that worksheet BRD sub set - atomized only contains titles in row 1.

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 ForEachXCreateNewRow()
' hiker95, 02/22/2015, ME837663
Dim wbs As Worksheet, wba As Worksheet
Dim r As Long, lr As Long, c As Long, nr As Long
Application.ScreenUpdating = False
Set wbs = Sheets("BRD sub set")
Set wba = Sheets("BRD sub set - atomised")
With wbs
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = 2 To lr
    For c = 9 To 14 Step 1
      If .Cells(r, c) = "X" Then
        nr = wba.Cells(wba.Rows.Count, "A").End(xlUp).Row + 1
        wbs.Range("A" & r & ":H" & r).Copy wba.Range("A" & nr)
        wba.Range("I" & nr).Value = wbs.Cells(1, c).Value
        wbs.Range("O" & r & ":AH" & r).Copy wba.Range("J" & nr)
        Application.CutCopyMode = False
      End If
    Next c
  Next r
End With
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, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ForEachXCreateNewRow macro.