Question

I have an excel,where near about 156 columns and 2000 rows.Here 36 tasks are being audited,where each taks has been described by 4 columns – say “Task1 Name”,”Task1 Start Date”,”Task1 Completion Date”,”Total Time Spent in Task1″.Now some times each of such 4 columns can have values for all and some times all the 4 columns dodes not have values to it.Now Goal is to find out such a 4-tuple set where atleast a single column data present.But if the data is not present then it will be told as unwanted set.So i need such unwanted columns to get moved one side and the partially filed or fullyfiled data in one side.But Non null dataset will move from right to left if its immediate preceded has 4 blank columns,otherwise or not. Find the input 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 no way producing correct data output..Please help me here

Answer 1

This code shifts all ‘populated’ 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