Results 1 to 13 of 13

Thread: Split Data

  1. #1
    2 Star Lounger
    Join Date
    Feb 2007
    Location
    Vienna, Wien, Austria
    Posts
    126
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Cool

    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 data-set????

    thanks in advance,
    stef
    Attached Files Attached Files

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 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

  3. #3
    2 Star Lounger
    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

  4. #4
    5 Star Lounger
    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

  5. #5
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 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

  6. #6
    2 Star Lounger
    Join Date
    Feb 2007
    Location
    Vienna, Wien, Austria
    Posts
    126
    Thanks
    0
    Thanked 0 Times in 0 Posts
    thank YOU both!!!

  7. #7
    2 Star Lounger
    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....
    Attached Images Attached Images

  8. #8
    5 Star Lounger
    Join Date
    Aug 2004
    Location
    Connecticut, USA
    Posts
    816
    Thanks
    0
    Thanked 0 Times in 0 Posts
    [quote name='Stefan_Sand' post='764917' date='11-Mar-2009 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?

  9. #9
    2 Star Lounger
    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...
    Attached Files Attached Files

  10. #10
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    Please explain in detail what should happen with the formulas.

  11. #11
    2 Star Lounger
    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.

  12. #12
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 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

  13. #13
    2 Star Lounger
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •