excel行中的数据分区 [英] Data partition in an excel row
问题描述
编辑:
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屋!