smart row generator based on columns

[modiria50989]

Hello,

Is there any Excel tool or VBA code to the following efficiently, thank you in advance:

I have a data sheet including a column of color names and a few columns of color codes in front of that. some colors have only 1 code, some 2, and some 3 codes. I need an efficient way that creates new row under a color that has 2 codes, and creates 2 new rows under a color that has 3 codes with the same color name. Unfortunately I don't see an option in this forum to attach my excel sheet. Anyway, for example, the date sheet (4-column) bellow is given and I need to get the second one (2-columns).

Just in case, in average, I'm dealing with a data sheet of "2000 Rows - 50 Columns".

color name <tbody> </tbody>	code1 <tbody> </tbody>	code2 <tbody> </tbody>	code3 <tbody> </tbody>
Absolute Zero Acajou Acid green Aero Aero blue African violet Air Force blue (RAF) Air Force blue (USAF) Air superiority blue Alabama crimson <tbody> </tbody>	#0048BA #4C2F27 68768 #7CB9E8 #C9FFE5 12863 #5D8AA8 #00308F #72A0C1 #AF002A <tbody> </tbody>	fax 79% 70% bucks 69% <tbody> </tbody>	18% man 434436 <tbody> </tbody>

<tbody>
</tbody>

color name <tbody> </tbody>	code <tbody> </tbody>
Absolute Zero Acajou Acajou Acajou Acid green Aero Aero Aero blue African violet African violet African violet Air Force blue (RAF) Air Force blue (USAF) Air Force blue (USAF) Air superiority blue Alabama crimson Alabama crimson Alabama crimson <tbody> </tbody>	#0048BA #4C2F27 fax 18% 68768 #7CB9E8 79% #C9FFE5 12863 70% man #5D8AA8 #00308F bucks #72A0C1 #AF002A 69% 434436 <tbody> </tbody>

<tbody>
</tbody>

 

[wideboydixon]

Give this macro a bash:

Public Sub TransposeData()

Dim lastRow As Long
Dim thisRow As Long
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim nextRow As Long
Dim lastCol As Long
Dim thisCol As Long

Set sourceSheet = ActiveSheet
Set targetSheet = Worksheets.Add(after:=sourceSheet)

lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
nextRow = 0
For thisRow = 2 To lastRow
    lastCol = sourceSheet.Cells(thisRow, sourceSheet.Columns.Count).End(xlToLeft).Column
    For thisCol = 2 To lastCol
        nextRow = nextRow + 1
        sourceSheet.Cells(thisRow, "A").Copy targetSheet.Cells(nextRow, "A")
        sourceSheet.Cells(thisRow, thisCol).Copy targetSheet.Cells(nextRow, "B")
    Next thisCol
Next thisRow

End Sub

WBD

 

[alansidman]

try this: Create two worksheets, Data and Result.

Option Explicit




Sub Normalize()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim i As Long, lr As Long, lrt As Long
    Dim lc As Long
    Set s1 = Sheets("Data")
    Set s2 = Sheets("Result")
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False


    For i = 1 To lr
        lrt = s2.Range("B" & Rows.Count).End(xlUp).Row + 1
        lc = s1.Cells(i, Columns.Count).End(xlToLeft).Column
        s1.Range("A" & i).Copy s2.Range("A" & lrt)
        s1.Range(Cells(i, 2), Cells(i, lc)).Copy
        s2.Range("B" & lrt).PasteSpecial xlPasteValues, , , True
        Application.CutCopyMode = False
    Next i


    lrt = s2.Range("B" & Rows.Count).End(xlUp).Row
    For i = 3 To lrt
        If s2.Range("A" & i) = "" Then
            s2.Range("A" & i) = s2.Range("A" & i - 1)
        End If
    Next i


    Application.ScreenUpdating = True


End Sub

 

[modiria50989]

alansidman ,

Works. Thank you very much!

 

[modiria50989]

wideboydixon,

This is awesome! Thank you very much!

 

[modiria50989]

Now I am facing with a problem. Your code seems very memory hungry for large databases. It's loading over 1 hour and still loading. Maybe for loop is the problem, I have no idea. Could you please re right this without for loop? or I can send you my file to take a look if you dont mind. Thank you in advance. Just to know that my file has over 250000 rows and 169 columns. So the result would be about 250000*169 rows and 2 columns.

Give this macro a bash:

Public Sub TransposeData()

Dim lastRow As Long
Dim thisRow As Long
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim nextRow As Long
Dim lastCol As Long
Dim thisCol As Long

Set sourceSheet = ActiveSheet
Set targetSheet = Worksheets.Add(after:=sourceSheet)

lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
nextRow = 0
For thisRow = 2 To lastRow
    lastCol = sourceSheet.Cells(thisRow, sourceSheet.Columns.Count).End(xlToLeft).Column
    For thisCol = 2 To lastCol
        nextRow = nextRow + 1
        sourceSheet.Cells(thisRow, "A").Copy targetSheet.Cells(nextRow, "A")
        sourceSheet.Cells(thisRow, thisCol).Copy targetSheet.Cells(nextRow, "B")
    Next thisCol
Next thisRow

End Sub

WBD

 

[wideboydixon]

This may run a little quicker:

Public Sub TransposeData()

Dim lastRow As Long
Dim thisRow As Long
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim nextRow As Long
Dim lastCol As Long
Dim thisCol As Long

Application.ScreenUpdating = False

Set sourceSheet = ActiveSheet
Set targetSheet = Worksheets.Add(after:=sourceSheet)

lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
nextRow = 0
For thisRow = 2 To lastRow
    lastCol = sourceSheet.Cells(thisRow, sourceSheet.Columns.Count).End(xlToLeft).Column
    For thisCol = 2 To lastCol
        nextRow = nextRow + 1
        targetSheet.Cells(nextRow, "A").Value = sourceSheet.Cells(thisRow, "A").Value
        targetSheet.Cells(nextRow, "B").Value = sourceSheet.Cells(thisRow, thisCol).Value
    Next thisCol
Next thisRow

Application.ScreenUpdating = True

End Sub

WBD

 

[alansidman]

In addition to WideBoy's code add a line of code to make the calculation manual.

 

[Fluff]

So the result would be about 250000*169 rows and 2 columns.

If this is correct then you have a slight problem, as there are only 1,048,576 rows in excel & you're trying to use 42,250,000 rows

<colgroup><col width="64"></colgroup><tbody>
</tbody>

 

[modiria50989]

No, actually, I have a lot of empty cells under columns, so the real result needs about 900,000 rows.