excel - Excel行のデータパーティション

Question

私は約156列と2000行に近い優れた点を持っています。ここでは36のタスクが監査されており、各タスクは4つの列で記述されています。たとえば、「Task1 Name」、「Task1 Start Date」、「Task1CompletionDate」などです。 Task1で費やされた合計時間。これで、このような4つの列のそれぞれにすべての値が含まれる場合と、4つの列すべてに値が含まれない場合があります。目標は、少なくとも1つの4つのタプルセットを見つけることです。列データが存在しますが、データが存在しない場合は、不要なセットとして通知されます。そのため、このような不要な列を片側に移動し、部分的にファイルされたデータまたは完全にファイルされたデータを片側に移動する必要がありますが、null以外のデータセットは右から移動します直前に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