Splitting data in excel string

Question

I have excel where about 156 columns and 2000 rows. Here, 36 tasks are checked, where each taks is described by four columns - for example, “Name Task1”, “Launch date Task1”, “Completion date Task1”, “Total time spent on task 1.” Several times each of these 4 columns can have values ​​for all, and sometimes all four columns have no meaning for it.Now the goal is to find a set of 4 tuples, where at least data with one column, but if there is no data, it will be said as unwanted set, so I need unwanted columns so that they move with one . Second hand and partially or completely filled with submitted data on one side but not the null set of data will move from right to left, if it immediately precedes has 4 empty columns, or whether or not I See the table below.:

EDIT:

Sub DataShiftFromLeftToRight(Ob6) 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 Ob6 .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'Number of rows width = .Cells(i, .Columns.count).End(-4159).Column 'round width 'MsgBox(width) if (width -1 )mod columnInGroup <> 0 then width = (((width -1)\columnInGroup )+1)* columnInGroup + 1 end if if width > 1 then 'need to change to the column number 'finding the last unit originally packed redim rowArray(0,width-1) rowArray = .range(.cells(i,1), .cells(i,width)).value'here 1 need to change 'default value rWidth = width for j = 2 to width step ColumnInGroup'here j need to change 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 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 End Sub 

But this is code that does not provide the correct data output. Please help me here

Answer 1

This code shifts all "completed" tasks to the left:

 Sub ShiftTasks() Dim wst As Excel.Worksheet Dim lRow As Long Dim lTask As Long Dim lCol As Long Const NUM_TASKS As Long = 36 Const COL_FIRST As Long = 12 Set wst = ActiveSheet With wst For lRow = 2 To .UsedRange.Rows.Count lTask = 1 Do While lTask <= NUM_TASKS lCol = COL_FIRST + (lTask - 1) * 4 If Len(.Cells(lRow, lCol).Value) = 0 And _ Len(.Cells(lRow, lCol + 1).Value) = 0 And _ Len(.Cells(lRow, lCol + 2).Value) = 0 And _ Len(.Cells(lRow, lCol + 3).Value) = 0 Then ' make sure there is something to the right to shift over If .Cells(lRow, lCol).End(xlToRight).Column < .Columns.Count Then ' delete the empty cells and shift everything left`` .Range(.Cells(lRow, lCol), .Cells(lRow, lCol + 3)).Delete Shift:=xlToLeft Else ' force the loop to the next row lTask = NUM_TASKS + 1 End If Else lTask = lTask + 1 End If Loop Next lRow End With End Sub