excel - excel行中的数据分区

Question

我有一个 excel，大约有 156 列和 2000 行。这里正在审核 36 个任务，其中每个任务由 4 列描述 - 比如说“任务 1 名称”、“任务 1 开始日期”、“任务 1 完成日期”、在 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