Excel VBA Macro to split long row into many of equal length - excel

Question

I am currently working on a problem where I have an Excel Spreadsheet that I would like to use a VBA macro on. Each of the following 3 rows are consecutive.
Name of Data
abc A1 B2 B4 C4 E2 F43 d4 V8 f9 k11 j20 … x
cde A2 B3 B12 C6 E9 F34 d6 V4 f13 k111 j209 … x
efg A3 B5 B7 C8 E11 F68 d19 V12 f91 k114 j2014 … x
…
Desired
abc A1 B2 B4 C4 E2 F43 d4 V8
abc f9 k11 j20 …
cde A2 B3 B12 C6 E9 F34 d6 V4
cde f13 k111 j209 …
efg A3 B5 B7 C8 E11 F68 d19 V12
efg f91 k114 j2014 …
I have the data name for each row and some rows can be hundreds of entries long spanning hundreds columns. So what I would like to do would be make my row length stop at 8 columns wide. I would hope that the macro can check through each row to see if the length is greater than 8, insert a row with the same data name and paste the next 8 columns, subtract it from the total columns and paste the next row, until it has reached the end of the first long row, and continue checking through all the rows. In essense, it saves a whole lot of time from counting up 8 columns wide, cut and pasting it in an inserted row below, preserving all other data. I'm new to this, so macro or VBA help is much appreciated.
Thanks,
John

Answer 1

The below macro will do exactly as you ask. It has some assumptions that I'll leave to you to fix, such as
Data is in sheet 1
Name column is always A, all data columns start from B
Everything starts in cell A1
This macro will run through every row and, for those rows with more than 9 data elements, it will create a new row and populate it with the previous rows Name and the remaining data rows. It will continue doing this until there is less than or equal to 8 data elements per row.
Since you have MANY rows you say, it would be a good idea to turn off screen updating, like so Application.ScreenUpdating = False before the for loop and turn it back on after the for loop.
Public Sub SplitRows()
Dim rowRange As Variant
Dim colCount As Integer
Dim lastColumn As Long
Dim rowCount As Integer
rowCount = Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Integer
i = 1
Do While (i < rowCount)
lastColumn = Sheet1.Cells(i, Columns.Count).End(xlToLeft).Column
colCount = Sheet1.UsedRange.Columns.Count
rowRange = Range(Cells(i, 2), Cells(i, colCount))
'if the row has more than 9 values (name column + 8 data columns)
If Not lastColumn <= 8 Then
Dim x As Integer
'from column 2 (B, aka first data column) to last column
For x = 2 To colCount - 1
'if data is not empty AND x mod 8 is 1 (meaning 8 goes into x enough times to have a remainder of 1)
If Not IsEmpty(rowRange(1, x - 1)) And (x Mod 8) = 1 Then
Cells(i, 1).Offset(1).EntireRow.Insert 'insert new row below current row
rowCount = rowCount + 1 'update row count because we added a row
Sheet1.Cells(i + 1, 1).Value = Sheet1.Cells(i, 1).Value 'set first column name
Dim colsLeft As Integer
For colsLeft = x To colCount - 1
'take data value from col 9 to end and populate newly created row
Sheet1.Cells(i + 1, colsLeft - 7).Value = rowRange(1, colsLeft)
Sheet1.Cells(i, colsLeft + 1).Value = "" 'set data value from col 9 on and set to empty
Next
Exit For 'exit loop, weve done all we need to and must now check the newly populated row
End If
Next
End If
i = i + 1
Loop
End Sub
Here is a before and after of the results:
BEFORE
AFTER

Answer 2

Argh, I tried somewhat along this lines, but I have to go to work. Maybe it is helpful as a starting point.
Public Sub Test()
Dim mastercell As Range
Set mastercell = ActiveWorkbook.Worksheets(1).Cells(1, 1)
Dim masterValue As String
masterValue = mastercell.Value
If GetCount(masterValue) > 8 Then
Dim tempvalue As String
tempvalue = masterValue
Dim Rowcount As Integer
Dim ColCount As Integer
Rowcount = mastercell.Row
ColCount = mastercell.Column + 1
Do While GetCount(tempvalue) > 8
Dim WriteValue As String
WriteValue = GetFirstEight(tempvalue)
ActiveWorkbook.Worksheets(1).Cells(Rowcount, ColCount).Value = WriteValue
ColCount = ColCount + 1
tempvalue = Replace(tempvalue, WriteValue, 0, 1)
Loop
End If
End Sub
Private Function GetCount(str As String) As Integer
Dim Splitter As String
Splitter = " "
Dim SplitArray As Variant
SplitArray = Split(str)
GetCount = UBound(SplitArray)
End Function
Private Function GetFirstEight(str As String) As String
Dim i As Integer
Dim NewString As String
Dim SplitArray() As String
SplitArray = Split(str)
For i = 0 To 7
NewString = NewString & SplitArray(i) & " "
Next
GetFirstEight = NewString
End Function