excel行中的数据分区 [英] Data partition in an excel row

问题描述

我有一个excel，其中近156列和2000行。有36个任务被审计，其中每个taks已经被描述4列 - 说任务1名称，任务1开始日期，任务1完成日期，任务1中的总时间。现在有些时候，这4个列的每一个都可以有所有的值，所有的4列dode都没有值.Now目标是找到这样一个4元组，其中至少有一列列数据存在。但是如果数据不存在，那么它将被告知为不需要的集合。因此，我需要这些不需要的列来移动一边，并将一部分文件或完整的数据移动到一边。但是非空数据集将如果其直接前面有4个空白列，则从右到左移动，否则。找到下面的输入表：

编辑：

  Sub DataShiftFromLeftToRight ）
 
 
 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 
'假设第一行是标题
'从第二行开始
如果height> ; 1然后
对于i = 2到height'行数
 
 width = .Cells（i，.Columns.count）.End（-4159）.Column 
'round width 
'MsgBox（width）
 if（width -1）mod columnInGroup<> 0然后
 width =（（（width -1）\columnInGroup）+1）* columnInGroup + 1 
 end if 
 if width> 1然后'需要更改到列号
'找到最初打包的最后一个单元
 redim rowArray（0，width-1）
 rowArray = .range（.cells（i，1） ，.cells（i，width））。value'其中1需要更改
'默认值
 rWidth = width 
 for j = 2 to width step ColumnInGroup'here j需要更改
如果j + ColumnInGroup -1< = width then 
b = false 
 for k = 0 to ColumnInGroup  -  1 
 if rowArray（1，j + k） 然后
b = true 
退出
结束如果
下一个
如果不是b然后
 rWidth = j  -  1 
退出
 end if 
 else 
 rWidth = width 
 end if 
 next 
 
如果width> rWidth然后
 ReDim dataArray（1，（width  -  rWidth））
 dataArray = .Range（.Cells（i，rWidth + 1），.Cells（i，width））值
 
 count = 0 
 
对于j = LBound（dataArray，2）到UBound（dataArray，2）步骤ColumnInGroup 
如果j + ColumnInGroup  -  1< = ubound（dataArray，2 ）然后
b = false 
 for k = 0 to ColumnInGroup  -  1 
如果dataArray（1，j + k） 然后
b = true 
退出
结束如果
 next 
如果b然后
 count = count + 1 
 end if 
 else 
退出
结束如果
下一个
 
 ReDim packArray（0，count * columnInGroup  -  1）
 count = 0 
对于j = LBound（dataArray，2）到UBound（dataArray，2）Step columnInGroup 
'我们发现一个T单位
如果j + columnInGroup -1 <= ubound（dataArray，2）then 
b = false 
 for k = 0 to ColumnInGroup  -  1 
如果dataArray（1，j + k） 然后
b = true 
退出
结束如果
下一个
如果b然后
 count = count + 1 
 for k = 0 to columnInGroup  -  1 
如果j + k <= UBound（dataArray，2）然后
 packArray（0，（count  -  1）* columnInGroup + k）= dataArray（1，j + k）
 end if 
 next 
 end if 
 
 else 
 exit for 
 end if 
 
 Next 
 
'清除原始数据
 .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 
  

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

解决方案

此代码将所有填充任务向左：

  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 
 
设置wst = ActiveSheet 
 
使用wst 
 
对于lRow = 2 To .UsedRange.Rows.Count 
 lTask​​ = 1 
尽管lTask​​< ; = NUM​​_TASKS 
 lCol = COL_FIRST +（lTask​​  -  1）* 4 
如果Len（.Cells（lRow，lCol）.Value）= 0和_ 
 Len（.Cells（lRow，lCol + 1）.Value） = 0和_ 
 Len（.Cells（lRow，lCol + 2）.Value）= 0和_ 
 Len（.Cells（lRow，lCol + 3）.Value）= 0然后
'确保有权向右移动
如果.Cells（lRow，lCol）.End（xlToRight）.Column< .Columns.Count然后
'删除空单元格并移动所有的东西
 .Range（.Cells（lRow，lCol），.Cells（lRow，lCol + 3））。删除Shift：= xlToLeft 
 Else 
'强制循环到下一行
 lTask​​ = NUM​​_TASKS + 1 
 End If 
 Else 
 lTask​​ = lTask​​ + 1 
结束如果
循环
下一个lRow 
结束
 
 End Sub 
  

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

解决方案

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

这篇关于excel行中的数据分区的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！