Results 1 to 13 of 13
Thread: Split Data

20090311, 08:27 #1
 Join Date
 Feb 2007
 Location
 Vienna, Wien, Austria
 Posts
 126
 Thanks
 0
 Thanked 0 Times in 0 Posts
hello all,
i have a long list (about 5000 rows) where I should split the data into as many rows as there are devices (see example) and to add a number at the end in column k. has anyone an idea to solve such problems instead of doing it hand by hand for every dataset????
thanks in advance,
stef

20090311, 11:14 #2
 Join Date
 Mar 2002
 Posts
 84,353
 Thanks
 0
 Thanked 30 Times in 30 Posts
Try this macro:
Code:Sub SplitDevices() Dim r As Long Dim m As Long Dim c As Long Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual m = Cells(Rows.Count, 9).End(xlUp).Row For r = m To 2 Step 1 c = Cells(r, 9) If c > 1 Then Rows(r).Copy Range((r + 1) & ":" & (r + c  1)).Insert Range(Cells(r, 9), Cells(r + c  1, 9)) = 1 End If Next r Application.CutCopyMode = False Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub

20090311, 11:24 #3
 Join Date
 Feb 2007
 Location
 Vienna, Wien, Austria
 Posts
 126
 Thanks
 0
 Thanked 0 Times in 0 Posts
so it replaces the former data... thanks for the moment, i have to test it for a while.
stef

20090311, 11:26 #4
 Join Date
 Aug 2004
 Location
 Connecticut, USA
 Posts
 816
 Thanks
 0
 Thanked 0 Times in 0 Posts
Try this one. It will expand the current table in its current location.
Code:Sub splitIt() Application.ScreenUpdating = False Dim i As Long, rColor As Integer, iBeg As Long, iEnd As Long For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step 1 If Cells(i, 9) = 1 Then Else Range(Cells(i, 1), Cells(i, 1).Offset(Cells(i, 9)  2)).EntireRow.Insert Shift:=xlDown End If Next For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step 1 If Cells(i, 1) <> "" Then Cells(i, 11) = Cells(i, 9) rColor = Cells(i, 1).Interior.ColorIndex iBeg = i iEnd = i  (Cells(i, 9)  1) With Range(Cells(iEnd, 1), Cells(iBeg, 11)) .Interior.ColorIndex = rColor .Borders.LineStyle = xlNone End With With Range(Cells(iEnd, 1), Cells(iBeg, 11)).Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Range(Cells(iEnd, 1), Cells(iBeg, 11)).Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Range(Cells(iEnd, 1), Cells(iBeg, 11)).Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Range(Cells(iEnd, 1), Cells(iBeg, 11)).Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With End If Next For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step 1 If Cells(i, 1) <> "" Then Cells(i, 11) = Cells(i, 9) Cells(i, 9) = 1 Else Range(Cells(i + 1, 1), Cells(i + 1, 11)).AutoFill _ Destination:=Range(Cells(i, 1), Cells(i + 1, 11)), Type:=xlFillValues Cells(i, 9) = 1 Cells(i, 11) = Cells(i + 1, 11)  1 End If Next For i = 1 To 11 Cells(2, i).NumberFormat = Cells(3, i).NumberFormat Cells(2, i).Font.Bold = False Cells(2, i).HorizontalAlignment = Cells(3, i).HorizontalAlignment Next Cells(2, 8).Font.Bold = True Application.ScreenUpdating = True End Sub End Sub

20090311, 11:40 #5
 Join Date
 Mar 2002
 Posts
 84,353
 Thanks
 0
 Thanked 30 Times in 30 Posts
Oops, I forgot column K. Here is a modified version:
Code:Sub SplitDevices() Dim r As Long Dim m As Long Dim c As Long Dim i As Long Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual m = Cells(Rows.Count, 9).End(xlUp).Row For r = m To 2 Step 1 c = Cells(r, 9) If c > 1 Then Rows(r).Copy Range((r + 1) & ":" & (r + c  1)).Insert For i = 1 To c Cells(r + i  1, 9) = 1 Cells(r + i  1, 11) = i Next i End If Next r Application.CutCopyMode = False Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub

20090311, 14:02 #6
 Join Date
 Feb 2007
 Location
 Vienna, Wien, Austria
 Posts
 126
 Thanks
 0
 Thanked 0 Times in 0 Posts
thank YOU both!!!

20090311, 15:14 #7
 Join Date
 Feb 2007
 Location
 Vienna, Wien, Austria
 Posts
 126
 Thanks
 0
 Thanked 0 Times in 0 Posts
sorry for a last question:
if i have aditional data  see picture  i get an error if i expand the columns  and the data are filled as many rows as are in column M described....

20090311, 15:21 #8
 Join Date
 Aug 2004
 Location
 Connecticut, USA
 Posts
 816
 Thanks
 0
 Thanked 0 Times in 0 Posts
[quote name='Stefan_Sand' post='764917' date='11Mar2009 16:14']sorry for a last question:
if i have aditional data  see picture  i get an error if i expand the columns  and the data are filled as many rows as are in column M described....[/quote]
Since these columns weren't included in the original sheet, we could compensate for their existence. How are the extra columns linked to the columns you posted? You mention an error, but do not state the actual error.
Can you post another workbook with these column in it?

20090311, 16:38 #9
 Join Date
 Feb 2007
 Location
 Vienna, Wien, Austria
 Posts
 126
 Thanks
 0
 Thanked 0 Times in 0 Posts
i attached my additions  the workbook contains all your makros and i tried hans second one because i got the number there...

20090311, 16:51 #10
 Join Date
 Mar 2002
 Posts
 84,353
 Thanks
 0
 Thanked 30 Times in 30 Posts
Please explain in detail what should happen with the formulas.

20090311, 17:37 #11
 Join Date
 Feb 2007
 Location
 Vienna, Wien, Austria
 Posts
 126
 Thanks
 0
 Thanked 0 Times in 0 Posts
the formulas should only be filled down, but i can use values instead of formulas.
the most interesting formula is the one in column M for it gives me the value for each single device.
the number in column k i use for a vlookup after data splitting, linked to the location(s)  there are always two location per 2 devices.

20090311, 17:49 #12
 Join Date
 Mar 2002
 Posts
 84,353
 Thanks
 0
 Thanked 30 Times in 30 Posts
I don't understand why you changed Cells(r, 9) to Cells(r, 12). The number of devices is still in column I (the 9th column).
For the BaseData sheet, you should stop at row 5 instead of row 2, because rows 1 through 4 contain header information.
In the following version, all formulas are replaced with values.
Code:Sub SplitDevices2() Dim r As Long Dim m As Long Dim c As Long Dim i As Long Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual ' Replace formulas with values With ActiveSheet.UsedRange .Value = .Value End With m = Cells(Rows.Count, 9).End(xlUp).Row For r = m To 5 Step 1 c = Cells(r, 9) If c > 1 Then Rows(r).Copy Range((r + 1) & ":" & (r + c  1)).Insert For i = 1 To c Cells(r + i  1, 9) = 1 Cells(r + i  1, 11) = i Next i End If Next r Application.CutCopyMode = False Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub

20090311, 18:14 #13
 Join Date
 Feb 2007
 Location
 Vienna, Wien, Austria
 Posts
 126
 Thanks
 0
 Thanked 0 Times in 0 Posts
Hans, You saved my week, thank You and have a good night.
stef