EDIT:make the number of column in a group from 3 to N (ColumnInGroup)
EDIT: Fixed some bugs, and allow "NAME" field to be empty, a "T" type is treated as exist if either Name, start date, end date exist, improved performance by assigning back in ROW unit instead of cell unit
EDIT:Fixed a bug
EDIT:
I get the value of these constant in VBA, you open an excel, Alt + F11 to open VB Editor, Crtl + G open an immediate window, type ?xlUp , it will show the value of xlUp below
The Code Below is in VBS, works on the sheet you currently display
and the performance should be okay...
Change the Workbook full path, worksheet name to use
Option Explicit
Dim xlApp
Dim xlBook
dim xlSheet
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
xlApp.EnableEvents = False
xlApp.ScreenUpdating = False
'xlApp.Calculation = -4135 'xlCalculationManual
set xlBook = xlApp.Workbooks.Open("C:UserswangCLDesktopdata.xlsx")
set xlSheet = xlBook.Worksheets("data (4)")
'CONTENT HERE
Dim count
Dim dataArray
Dim height
Dim width
Dim rWidth
Dim packArray
Dim i
Dim j
dim rowArray
dim ColumnInGroup
dim k
dim b
With xlSheet
.activate
ColumnInGroup= 4
height = .Cells(.Rows.count, 1).End(-4162).Row
' assume 1st line is header
' start from 2nd line
If height > 1 Then
For i = 2 To height
width = .Cells(i, .Columns.count).End(-4159).Column
'round width
if (width -1 )mod columnInGroup <> 0 then
width = (((width -1)columnInGroup )+1)* columnInGroup + 1
end if
if width > 1 then
'finding the last unit originally packed
redim rowArray(0,width-1)
rowArray = .range(.cells(i,1), .cells(i,width)).value
'default value
rWidth = width
for j = 2 to width step ColumnInGroup
if j+ColumnInGroup -1 <= width then
b = false
for k = 0 to ColumnInGroup - 1
if rowArray(1,j+k) <> "" then
b = true
exit for
end if
next
if not b then
rWidth = j - 1
exit for
end if
else
rWidth = width
end if
next
'rWidth = .Cells(i, 1).End(-4161).Column
'If .Cells(i, rWidth - 1).Value = "" Then
' rWidth = 1
'End If
''check for each new "T" - 1
'If rWidth Mod 3 = 0 Then
' rWidth = rWidth + 1
'ElseIf rWidth Mod 3 = 1 Then
' rWidth = rWidth
'ElseIf rWidth Mod 3 = 2 Then
' rWidth = rWidth + 2
'End If
' if is not packed
If width > rWidth Then
ReDim dataArray(1 ,(width - rWidth))
dataArray = .Range(.Cells(i, rWidth + 1), .Cells(i, width)).Value
count = 0
For j = LBound(dataArray, 2) To UBound(dataArray, 2) Step ColumnInGroup
if j+ColumnInGroup - 1<= ubound(dataArray,2) then
b = false
for k = 0 to ColumnInGroup - 1
if dataArray(1,j+k) <> "" then
b = true
exit for
end if
next
if b then
count = count + 1
end if
else
exit for
end if
Next
ReDim packArray(0, count * columnInGroup - 1)
count = 0
For j = LBound(dataArray, 2) To UBound(dataArray, 2) Step columnInGroup
' we found a "T" Unit
if j+columnInGroup -1<= ubound(dataArray,2) then
b = false
for k = 0 to ColumnInGroup - 1
if dataArray(1,j+k) <> "" then
b = true
exit for
end if
next
if b then
count = count + 1
for k = 0 to columnInGroup - 1
If j + k <= UBound(dataArray, 2) Then
packArray(0, (count - 1) * columnInGroup + k ) = dataArray(1, j + k)
end if
next
end if
else
exit for
end if
Next
'clear original data
.Range(.Cells(i, rWidth + 1), .Cells(i, width)).ClearContents
'for j = 1 to ubound(packArray,2)
' .cells(i,rWidth+j).value = packArray(1,j)
' next
.Range(.Cells(i, rWidth + 1), .Cells(i, rWidth + count * columnInGroup)).Value = packArray
End If
end if
Next
End If
End With
xlBook.save
xlApp.Quit
set xlSheet = nothing
set xlBook = nothing
set xlApp = nothing
msgbox "Done"
