New Line Data

[Craddox]

Hi, I am struggling.... So what's new.

I have a worksheet in excel that has multiple rows and mutliple columns populated through VBA as text and numbers. Part of this is that from column S through to column XFD there could be a number that needs moving to the next line on the same worksheet. Once the number has been moved, the rest of the row (columns A through R) need to be copied to the same "new" row as the number. The code then needs to move onto the next column and do the same then once the row is completely checked it needs to move onto the next row and do the same again.

Some rows don't have any numbers in S:XFD and others could have numbers in every column.

Does anyone have any clues on how to do this and is this even possible?

 

[Craddox]

Sheet output image

 

[Jeffrey Mahoney]

Let's make sure your data is where the macro expects it

You might want to change this line so it shows the correct sheet name. This is for the Out Table (where to copy the data. OutS is the header at the top of ColumnS, if it begins in a different cell, by all means change it.

Set NewSht = Sheets("Sheet2")   'Copy the data to this sheet
Set OutS = NewSht.Range("S1")   'Top of table where data needs to be copied

This line is where the data in the table starts in your active sheet. You may want to change that cell address

Set Cel = Range("A2")           'Starting row of data to be copied

The macro relies on you starting the macro with the sheet active where the original table resides.

Add this code in and then make the changes suggested above

Sub CreateNewLines()
  Dim Cel As Range
  Dim CC As Range
  Dim Rng As Range
  Dim aSht As Worksheet
  Dim NewSht As Worksheet
  Dim ColTAJ As Range
  Dim ColAS As Range
  Dim OutS As Range
  Dim OutCel As Range
  Dim OutRng As Range
  
  Application.Calculation = xlCalculationManual
  
  Set aSht = ActiveSheet
  Set ColAS = aSht.Range("A:S")
  Set ColTAJ = aSht.Range("T:AJ")
  Set NewSht = Sheets("Sheet2")   'Copy the data to this sheet
  Set OutS = NewSht.Range("S1")   'Top of table where data needs to be copied
  
  Set Cel = Range("A2")           'Starting row of data to be copied
  With aSht
    Set Rng = Range(Cel, .Cells(.Cells.Rows.Count, 1).End(xlUp))  'Values in column A
  End With
  
  For Each Cel In Rng
    Set OutCel = NewSht.Cells(NewSht.Rows.Count, OutS.Column).End(xlUp).Offset(1, 0)  'Next blank row
    Set OutRng = Intersect(NewSht.Range("A:S"), OutCel.EntireRow)                     'Columns A - S
    OutRng.Value = Intersect(Cel.EntireRow, ColAS).Value
    For Each CC In Intersect(ColTAJ, Cel.EntireRow)
      If CC.Value <> "" Then
        Set OutCel = NewSht.Cells(NewSht.Rows.Count, OutS.Column).End(xlUp).Offset(1, 0)  'Next blank row
        Set OutRng = Intersect(NewSht.Range("A:S"), OutCel.EntireRow)                     'Columns A - S
        OutRng.Value = Intersect(Cel.EntireRow, ColAS).Value
        OutCel.Value = CC.Value                                                           'Copy new value
      End If
    Next CC
  Next Cel
  
  Application.Calculation = xlCalculationAutomatic
  
End Sub