Insert blank rows based on a number, then copy/paste values

[BigBee11]

Hello Excel Pros,

I've somewhat unique excel problem and it's taking a lot of my time because I do it pretty much manually. I'm asking all the pros to help me figure out a quicker way to get this done. Below is how I get data in excel sheet:

company	#of fices	city1	city2	city3	city4	city5	city6	city7	city1-PR	city1-NP	city1-AS	city1-OL	city2-PR	city2-NP	city2-AS	city2-OL	city3-PR	city3-NP	city3-AS	city3-OL	city4-PR	city4-NP	city4-AS	city4-OL	city5-PR	city5-NP	city5-AS	city5-OL	city6-PR	city6-NP	city6-AS	city6-OL	city7-PR	city7-NP	city7-AS	city7-OL
company1	5	Baton Rouge, Louisiana	New Orleans, Louisiana	Shreveport, Louisiana	Lake Charles, Louisiana	South Baton Rouge, Louisiana	62	0	36	9	17	0	15	2	6	0	1	0	1	0	0	0	2	0	0	0
company2	3	Chicago, IL	Durham, NC	Mountain View, CA				39	21	21	2	0	0	0	0	0	0	0	0
company3	7	Miami, Florida	Tampa, Florida	Fort Lauderdale, Florida	Orlando, Florida	Jacksonville, Florida	Kingston, Jamaica	Nassau, The Bahamas	2	13	10	2	1	4	5	0	0	0	0	0	0	0	0	0	0	0	1	0	0	0	0	1	0	1	0	0

<colgroup><col style="mso-width-source:userset;mso-width-alt:9472;width:194pt" width="259"> <col style="width:48pt" span="36" width="64"> </colgroup><tbody>
</tbody>

And how the final output would look:

Company	CITY	PR	NP	AS	OL
company1	Baton Rouge, Louisiana	62	0	36	9
company1	New Orleans, Louisiana	17	0	15	2
company1	Shreveport, Louisiana	6	0	1	0
company1	Lake Charles, Louisiana	1	0	0	0
company1	South Baton Rouge, Louisiana	2	0	0	0
company2	Chicago, IL	39	21	21	2
company2	Durham, NC	0	0	0	0
company2	Mountain View, CA	0	0	0	0
company3	Miami, Florida	2	13	10	2
company3	Tampa, Florida	1	4	5	0
company3	Fort Lauderdale, Florida	0	0	0	0
company3	Orlando, Florida	0	0	0	0
company3	Jacksonville, Florida	0	0	1	0
company3	Kingston, Jamaica	0	0	0	1
company3	Nassau, The Bahamas	0	1	0	0

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

I need to insert blank rows based on #of offices and copy/paste each city data per row. what would be the best/easiest way to do this? Thanks in advance for your help!

 

[Fluff]

Hi & welcome to MrExcel.

How about this, it will put the data on a new sheet.

Sub RearrangeData()

   Dim i As Long, j As Long, k As Long
   Dim Rws As Long
   Dim NxtRw As Long
   Dim Ws As Worksheet
   
   Set Ws = Sheets("[COLOR=#ff0000]Output[/COLOR]")
   Ws.Range("A1:F1").Value = Array("Company", "CITY", "PR", "NP", "AS", "OL")
   With Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
      For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
         Rws = .Range("B" & i).Value
         NxtRw = Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
         Ws.Range("A" & NxtRw).Resize(1 * Rws).Value = .Range("A" & i).Value
         Ws.Range("B" & NxtRw).Resize(Rws).Value = Application.Transpose(.Range("C" & i).Resize(, Rws))
         k = 10
         For j = 1 To Rws
            Ws.Range("C" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = .Cells(i, k).Resize(, 4).Value
            k = k + 4
         Next j
      Next i
   End With
End Sub

Change sheet names in red to suit

 

[BigBee11]

Thank you very much. I have data in more than 300 rows and 400 columns with many blanks cells. When I tried this, I didn't correctly copies and pasted the values. How can I modify this to work for large number of rows and columns. Thanks!

Hi & welcome to MrExcel.

How about this, it will put the data on a new sheet.

Sub RearrangeData()

   Dim i As Long, j As Long, k As Long
   Dim Rws As Long
   Dim NxtRw As Long
   Dim Ws As Worksheet
   
   Set Ws = Sheets("[COLOR=#ff0000]Output[/COLOR]")
   Ws.Range("A1:F1").Value = Array("Company", "CITY", "PR", "NP", "AS", "OL")
   With Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
      For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
         Rws = .Range("B" & i).Value
         NxtRw = Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
         Ws.Range("A" & NxtRw).Resize(1 * Rws).Value = .Range("A" & i).Value
         Ws.Range("B" & NxtRw).Resize(Rws).Value = Application.Transpose(.Range("C" & i).Resize(, Rws))
         k = 10
         For j = 1 To Rws
            Ws.Range("C" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = .Cells(i, k).Resize(, 4).Value
            k = k + 4
         Next j
      Next i
   End With
End Sub

Change sheet names in red to suit

 

[Fluff]

Without an accurate sample of your sheet I can't tell.

 

[Fluff]

How about

Sub RearrangeData()

   Dim i As Long, j As Long, k As Long
   Dim Rws As Long
   Dim NxtRw As Long
   Dim ws As Worksheet
   
   Set ws = Sheets("Output")
   ws.Range("A1:F1").Value = Array("Company", "CITY", "PR", "NP", "AS", "OL")
   With Sheets("Flip")
      For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
         Rws = .Range("B" & i).Value
         NxtRw = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
         ws.Range("A" & NxtRw).Resize(1 * Rws).Value = .Range("A" & i).Value
         ws.Range("B" & NxtRw).Resize(Rws).Value = Application.Transpose(.Range("C" & i).Resize(, Rws))
         k = 83
         For j = 1 To Rws
            ws.Range("C" & NxtRw).Resize(, 4).Value = .Cells(i, k).Resize(, 4).Value
            NxtRw = NxtRw + 1
            k = k + 4
         Next j
      Next i
   End With
End Sub

 

[BigBee11]

GREAT, this works, many thanks!

How about

Sub RearrangeData()

   Dim i As Long, j As Long, k As Long
   Dim Rws As Long
   Dim NxtRw As Long
   Dim ws As Worksheet
   
   Set ws = Sheets("Output")
   ws.Range("A1:F1").Value = Array("Company", "CITY", "PR", "NP", "AS", "OL")
   With Sheets("Flip")
      For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
         Rws = .Range("B" & i).Value
         NxtRw = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
         ws.Range("A" & NxtRw).Resize(1 * Rws).Value = .Range("A" & i).Value
         ws.Range("B" & NxtRw).Resize(Rws).Value = Application.Transpose(.Range("C" & i).Resize(, Rws))
         k = 83
         For j = 1 To Rws
            ws.Range("C" & NxtRw).Resize(, 4).Value = .Cells(i, k).Resize(, 4).Value
            NxtRw = NxtRw + 1
            k = k + 4
         Next j
      Next i
   End With
End Sub

 

[Fluff]

Glad to help & thanks for the feedback