Converting Columns into new rows with repeating data

P

pamelaamm

New Member
Joined
Nov 18, 2014
Messages
3
I have a table that looks like this. [TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]DealerName
[/TD]
[TD]DealerPhone
[/TD]
[TD]DealerAddress
[/TD]
[TD]DealerCity
[/TD]
[TD]DealerState
[/TD]
[TD]DealerZip
[/TD]
[TD]DealerEmail
[/TD]
[TD]BuildingName1
[/TD]
[TD]BuildingAddress1
[/TD]
[TD]BuildingCity1
[/TD]
[TD]BuildingState1
[/TD]
[TD]BuildingZip1
[/TD]
[TD]BuildingName2
[/TD]
[TD]BuildingAddress2
[/TD]
[TD]BuildingCity2
[/TD]
[TD]BuildingState2
[/TD]
[TD]BuildingZip2
[/TD]
[TD]UnneededColumn1
[/TD]
[TD]Date
[/TD]
[TD]UnneededColumn2
[/TD]
[TD]UnneededColumn3
[/TD]
[TD]CorpID
[/TD]
[/TR]
[TR]
[TD]PD Consulting
[/TD]
[TD]555-555-5555
[/TD]
[TD]1234 Consulting Drive
[/TD]
[TD]Cleveland
[/TD]
[TD]OH
[/TD]
[TD]44145
[/TD]
[TD]consulting@email.com
[/TD]
[TD]PDBuilding1
[/TD]
[TD]111 Address Ave
[/TD]
[TD]Westlake
[/TD]
[TD]OH
[/TD]
[TD]44145
[/TD]
[TD]Consulting2
[/TD]
[TD]222 Address Dr
[/TD]
[TD]North Olmsted
[/TD]
[TD]OH
[/TD]
[TD]44070
[/TD]
[TD]xxx
[/TD]
[TD]11/3/2014
[/TD]
[TD]zzz
[/TD]
[TD]yyy
[/TD]
[TD]12345
[/TD]
[/TR]
[TR]
[TD]Michel Wireless
[/TD]
[TD]222-222-2222
[/TD]
[TD]2222 Wireless Way
[/TD]
[TD]Bay Village
[/TD]
[TD]OH
[/TD]
[TD]44076
[/TD]
[TD]wireless@email.com
[/TD]
[TD]WirelessBuilding1
[/TD]
[TD]111 Cell St
[/TD]
[TD]Solon
[/TD]
[TD]OH
[/TD]
[TD]44139
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]bbb
[/TD]
[TD]10/3/2014
[/TD]
[TD]rrr
[/TD]
[TD]ttt
[/TD]
[TD]45677
[/TD]
[/TR]
</tbody>[/TABLE]


My problem I'm trying to solve for is to have a macro run that will take specified cells in a row (dealer information) and duplicate to a new row for each building that is listed in the columns. My table only shows 2 building data sets, however my actual spreadsheet holds 15. If building columns are left blank, I want the macro to skip to the next entry. Here is what I'd like the above data to look like:[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Date
[/TD]
[TD]BuildingName
[/TD]
[TD]BuildingAddress
[/TD]
[TD]BuildingCity
[/TD]
[TD]BuildingState
[/TD]
[TD]BuildingZip
[/TD]
[TD]CorpID
[/TD]
[TD]DealerName
[/TD]
[TD]DealerAddress
[/TD]
[TD]DealerCity
[/TD]
[TD]DealerState
[/TD]
[TD]DealerZip
[/TD]
[TD]DealerEmail
[/TD]
[TD]DealerPhone
[/TD]
[/TR]
[TR]
[TD]11/3/2014
[/TD]
[TD]PDBuilding1
[/TD]
[TD]111 Address Ave
[/TD]
[TD]Westlake
[/TD]
[TD]OH
[/TD]
[TD]44145
[/TD]
[TD]12345
[/TD]
[TD]PDConsulting
[/TD]
[TD]1234 Consulting Drive
[/TD]
[TD]Cleveland
[/TD]
[TD]OH
[/TD]
[TD]44145
[/TD]
[TD]consulting@email.com
[/TD]
[TD]555-555-5555
[/TD]
[/TR]
[TR]
[TD]11/3/2014
[/TD]
[TD]Consulting2
[/TD]
[TD]222 Address Dr
[/TD]
[TD]North Olmsted
[/TD]
[TD]OH
[/TD]
[TD]44070
[/TD]
[TD]12345
[/TD]
[TD]PDConsulting
[/TD]
[TD]1234 Consulting Drive
[/TD]
[TD]Cleveland
[/TD]
[TD]OH
[/TD]
[TD]44145
[/TD]
[TD]consulting@email.com
[/TD]
[TD]555-555-5555
[/TD]
[/TR]
[TR]
[TD]10/3/2014
[/TD]
[TD]WirelessBuilding1
[/TD]
[TD]111 Cell St
[/TD]
[TD]Solon
[/TD]
[TD]OH
[/TD]
[TD]44139
[/TD]
[TD]45677
[/TD]
[TD]Michel Wireless
[/TD]
[TD]2222 Wireless Way
[/TD]
[TD]Bay Village
[/TD]
[TD]OH
[/TD]
[TD]44076
[/TD]
[TD]wireless@email.com
[/TD]
[TD]222-222-2222
[/TD]
[/TR]
</tbody>[/TABLE]


So as you can see, it's a bit complicated in the sense that certain cells within a row need to repeat, columns need to split into new rows, blanks need to be ignored, and certain columns can also be ignored. I'm very new to VBA, so I've been doing a lot of research and have found the following solution works, but I cannot manipulate it enough to get the outcome desired. Any help is greatly greatly appreciated!! Thanks in advance!
Here is what I've been trying to manipulate:

Sub ShrinkTable()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column data = Range(Cells(1, 1), Cells(maxRows, maxCols))

Dim newSht As Worksheet
Set newSht = Sheets.Add

With newSht

.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Column"

Dim writeRow As Double writeRow = 2

Dim row As Double
row = 2
Dim col As Integer

Do While True

col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks

'Name
.Cells(writeRow, 1).Value = data(row, 1)

'Language
.Cells(writeRow, 2).Value = data(row, col)

writeRow = writeRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop

If row = maxRows Then Exit Do 'exit clause
row = row + 1
Loop

End With
End Sub
EXAMPLE:
| A | B | C | D |
+-------+------------+------------+------------+
1 | Name | Language 1 | Language 2 | Language 3 |
+=======+============+============+============+
2 | John | English | Chinese | Spanish |
3 | Wendy | Chinese | French | English |
4 | Peter | Spanish | Chinese | English |<br><br>And I want to generate a table that has only one language column. The other two language columns should become new rows like this:

| A | B |
+-------+----------+
1 | Name | Language |
+=======+==========+
2 | John | English |
3 | John | Chinese |
4 | John | Spanish |
5 | Wendy | Chinese |
6 | Wendy | French |
7 | Wendy | English |
8 | Peter | Spanish |
9 | Peter | Chinese |
10 | Peter | English |
 
Last edited:

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
Below are the input and output data


Excel 2010
ABCD
1NameLanguage1Language2Language3
2JohnEnglishChineseSpanish
3WendyChineseFrenchEnglish
4PeterSpanishChineseEnglish
Sheet1



Excel 2010
AB
1NameLanguage
2JohnEnglish
3JohnChinese
4JohnSpanish
5WendyChinese
6WendyFrench
7WendyEnglish
8PeterSpanish
9PeterChinese
10PeterEnglish
Sheet2

Code: 
Sub RearrangeData()
    Dim wks As Worksheet, wks2 As Worksheet
    Dim I As Integer, j As Integer, lrow As Integer
    
    Set wks = Worksheets("Sheet1")
    Set wks2 = Worksheets("Sheet2")
    
    With wks2
        .Range("A1:B1") = Array("Name", "Language")
    lrow = 2
    
    For I = 2 To wks.Range("A" & Rows.Count).End(xlUp).Row
        For j = 2 To wks.Cells(I, Columns.Count).End(xlToLeft).Column
            .Cells(lrow, 1) = wks.Cells(I, 1)
            .Cells(lrow, 2) = wks.Cells(I, j)
            lrow = lrow + 1
        Next j
    Next I
    End With
End Sub

The code assumes original data is in Sheet1 and the output is in sheet2, change as necessary
 
Upvote 0
Thank you so much for the reply - but I need code for fixing the first table. The second was just a simpler example. Anyway you could help with the first two tables shown?
 
Upvote 0
<p>
Definitely one of the most non-elegant codes i have written, but have a go at it</p>
 
Last edited:
Upvote 0
Code: 
Sub Rearrangedata()
    Dim wks As Worksheet, wks2 As Worksheet
    Dim I As Integer, j As Integer
    Dim lrow As Integer, K As Integer
    
    Set wks = Worksheets("Sheet1")
    Set wks2 = Worksheets("Sheet2")
    
    lrow = 2
    
    With wks2
    For I = 2 To wks.Range("A" & Rows.Count).End(xlUp).Row
        If wks.Range("M" & I).Value <> "" Then
            j = 2
        Else
            j = 1
        End If
        For K = 1 To j
                .Range("G" & lrow) = wks.Range("V" & I).Value
                .Range("H" & lrow) = wks.Range("A" & I).Value
                .Range("I" & lrow) = wks.Range("C" & I).Value
                .Range("J" & lrow) = wks.Range("D" & I).Value
                .Range("K" & lrow) = wks.Range("E" & I).Value
                .Range("L" & lrow) = wks.Range("F" & I).Value
                .Range("M" & lrow) = wks.Range("G" & I).Value
                .Range("N" & lrow) = wks.Range("B" & I).Value
            If K = 1 Then
                .Range("A" & lrow) = wks.Range("S" & I).Value
                .Range("B" & lrow) = wks.Range("H" & I).Value
                .Range("C" & lrow) = wks.Range("I" & I).Value
                .Range("D" & lrow) = wks.Range("J" & I).Value
                .Range("E" & lrow) = wks.Range("K" & I).Value
                .Range("F" & lrow) = wks.Range("L" & I).Value
                lrow = lrow + 1
            Else
                .Range("A" & lrow) = wks.Range("S" & I).Value
                .Range("B" & lrow) = wks.Range("M" & I).Value
                .Range("C" & lrow) = wks.Range("N" & I).Value
                .Range("D" & lrow) = wks.Range("O" & I).Value
                .Range("E" & lrow) = wks.Range("P" & I).Value
                .Range("F" & lrow) = wks.Range("Q" & I).Value
                lrow = lrow + 1
            End If
        Next K
    Next I
    End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
[VBA or excel function]- how to get value from certain cell in row/column match
Replies
1
Views
505
hajiali
H
M
  • Question Question
Code to stack by row first rather than by column?
Replies
1
Views
912
MeghanES
M
L
  • Solved
Inserting new rows base on cell value, copying cell value on the first 3 column and transpose data for the rest
2
Replies
15
Views
965
Legacy 143009
L
J
  • Question Question
Inserting new rows based on cell columns, copying data to the new rows
Replies
1
Views
450
OaklandJim
O
K
  • Solved
Add a new row in Named Table (Table1) and add data from txtboxes into last empty cells based on header named of the Table1
Replies
7
Views
692
karl2022
K

Forum statistics

Threads
1,223,214
Messages
6,170,771
Members
452,353
Latest member
strainu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top