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

 

[EmicoCP]

My friend... you are a legend!

One observation after running it against the data I have was that the number of records I expected was much less. Even less than the original set. Could this be because some records are being skipped? E.g. those without a value in column "A"

 

[hiker95]

EmicoCP,

My friend... you are a legend!

Thanks for the feedback.

You are very welcome. Glad I could help.

One observation after running it against the data I have was that the number of records I expected was much less. Even less than the original set. Could this be because some records are being skipped? E.g. those without a value in column "A"

The macro gets the last used row of your raw data from column A. If there are records in column A down to say row 100, and, your data set goes to 150, then yes the macro will not get them all.

against the data I have

It sounds like we have not see a good example of your actual raw data set.

Be back in a little while with an updated macro.

 

[hiker95]

EmicoCP,

I found that some of the X's in columns I thru N had either leading or trailing space characters.

And, there is information in your original posted workbook in just range AK8074:AL12074?

I removed some of the information in column A for testing, and, removed any leading or trailing space characters in columns I thru N, and, the new macro works correctly.

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 ForEachXCreateNewRowV2()
' hiker95, 02/23/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.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  With .Range("I2:N" & lr)
    .Value = Evaluate("IF(ISTEXT(" & .Address & "),TRIM(" & .Address & "),REPT(" & .Address & ",1))")
  End With
  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 ForEachXCreateNewRowV2 macro.

 

[EmicoCP]

Hi, I tried the new code against both the example spreadsheet I shared and the original set I have here and nothing actually happened when I ran it. Any thoughts?

Ignore this. I think I know what happened... Will check and come back.

 

[EmicoCP]

Ok, ignore the last comment. I accidentally deleted all of the "x" values when trying to remove leading/trailing spaces. Which leads me on to what I think is the final requirement here. Where columns I-N in the original worksheet have no "x" value in them, the macro ignores the entire row. Can the macro be adjusted to bring the row across to the new worksheet nonetheless?

 

[EmicoCP]

Ah... also, I'm still not getting a full quota of records. I even tried replacing all empty cells with the string "N/A"...

seemed to have cracked it by replacing lower case "x" with upper case!

 

[hiker95]

EmicoCP,

when trying to remove leading/trailing spaces

You do not have to do that - the macro does it for you.

seemed to have cracked it by replacing lower case "x" with upper case!

You do not have to do that. See the BOLD line of code.


Just add the additional line of code above the line beginning with Sub.

Option Compare Text
Sub ForEachXCreateNewRowV2()

 

[EmicoCP]

Hiker95, I just wanted to say thank you for helping me here. It's very much appreciated. I wish you all the very best.

 

[hiker95]

EmicoCP,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.

I wish you all the very best.

And, you also.