excel行中的数据分区

Question

我有一个excel，大约有156列和2000行。这36个任务正在被审计，其中每个taks已被4列描述 - 比如说“Task1 Name”，“Task1 Start Date”，“Task1 Completion Date” “，”在Task1中花费的总时间“。现在有些时候，这4列中的每一列都可以拥有全部值，有时候所有4列的所有代码都没有值。现在的目标是找出这样的4元组集至少存在一个列数据。但是如果数据不存在那么它将被告知为不需要的集合。所以我需要这样不需要的列在一侧移动而部分存档或完全存档的数据在一侧。但是非空数据集将如果紧接着之前有4个空白列，则从右向左移动，否则。找到下面的输入表：

编辑：

  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

但这是代码无法产生正确的数据输出.. 请在这里帮助我

Answer 1

此代码将所有“填充”任务移到左侧：

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