如果任何一组单元格使用VBScript空白而不使用任何循环技术，则可以从右到左移动组中的单元格值？ [英] To move the cell values in a group from right to left if any group of cells are blank using VBScript without using any Looping technique?
本文介绍了如果任何一组单元格使用VBScript空白而不使用任何循环技术，则可以从右到左移动组中的单元格值？的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
（包装每行的数据，向左）
输入表： * / p>
项目＃T1Name T1StartDate T1FinishDate T2Name T2StartDate T2FinishDate T3Name T3StartDate T3FinishDate
11 S1 12/7/2012 19 / 7/2012 S2 12/7/2012 19/7/2012
12 S2 12/6/2012
13 S4 11/05/12 S6 12/5/10
输出表：
项目＃T1Name T1StartDate T1FinishDate T2Name T2StartDate T2FinishDate T3Name T3StartDate T3FinishDate
11 S1 12/7/2012 19/7/2012 S2 12/7/2012 19/7/2012
12 S2 12/6/2012
13 S4 11/05/12 S6 12/05/10
更新MY输出表
请先检查一下是否放错了！
Update1
项目＃T1Name T1StartDate T1FinishDate T2Name T2StartDate T2FinishDate T3Name T3StartDate T3FinishDate
10 S1 11/5/2011 S2 5/5/2011
11 S1 11/5/2011 5/4/2011 S1 11 / 5/2011 5/4/2011
Update2
项目＃T1Name T1StartDate T1FinishDate T2Name T2StartDate T2FinishDate T3Name T3StartDate T3FinishDate
11 11/5/2011 S1 11/5/2011 5/4/2011 S2 11/5/2011 5/4/2011
将此条目添加到表中，它没有正确移动。你可以检查吗？
更新的代码：
Option Explicit
Dim objExcel1，objWorkbook
Dim strPathExcel1
Dim objSheet1，IntRow1
Dim Task，Totltask
Dim DataArray（14），index，Counter
设置objExcel1 = CreateObject（Excel.Application）
strPathExcel1 =D：\VA\TestVBSScripts\Test.xlsx
设置objWorkbook = objExcel1.Workbooks.open（strPathExcel1）
设置objSheet1 = objExcel1.ActiveWorkbook.Worksheets（1）
IntRow1 = 2
而objSheet1.Cells（IntRow1,1）.Value<
Totltask = 2
index = 0
直到Totltask> 10
'MsgBox（嗨）
如果objSheet1.Cells（IntRow1，Totltask）.Value<> 或objSheet1.Cells（IntRow1，Totltask + 1）.Value<> 或objSheet1.Cells（IntRow1，Totltask + 2）.Value<> 然后
DataArray（index）= objSheet1.Cells（IntRow1，Totltask）.Value
DataArray（index + 1）= objSheet1.Cells（IntRow1，Totltask + 1）.Value
DataArray（index + 2）= objSheet1.Cells（IntRow1，Totltask + 2）.Value
index = index + 3
End If
Totltask = Totltask + 3
循环
Totltask = 2
计数器=索引-1
索引= 0
'MsgBox（Counter）
尽管索引< Counter
'MsgBox（Hi）
objSheet1.Cells（IntRow1，Totltask）.Value = DataArray（index）
objSheet1.Cells（IntRow1，Totltask + 1）.Value = DataArray index + 1）
objSheet1.Cells（IntRow1，Totltask + 2）.Value = DataArray（index + 2）
Totltask = Totltask + 3
index = index + 3
循环
擦除DataArray
直到Totltask> 10
objSheet1.Cells（IntRow1，Totltask）.Value =
Totltask = Totltask + 1
循环
IntRow1 = IntRow1 + 1
循环
'== =====================
objExcel1.ActiveWorkbook.SaveAs strPathExcel1
objExcel1.Workbooks.close
objExcel1.Application.Quit
'======================
***任何身体都可以建议我应该如何使其更快，如果可能的话？该代码是正确的，根据需要生成输出。但是太慢了。
解决方案
编辑：使组中的列数3到N（ColumnInGroup）
编辑：修复了一些错误，并允许NAME字段为空，如果名称，开始日期，结束日期存在，通过分配回ROW单元而不是单元格来提高性能
编辑：修正错误
$ p $ b我得到VBA中这些常量的值，你打开一个excel，
Alt + F11 打开VB编辑器，$ code> Crtl + G 打开一个即时窗口，键入？xlUp ，它将显示xlUp的值低于 下面的代码在VBS中，在您当前显示的工作表
上，性能应该是好的...
更改工作簿的完整路径，工作表名称使用
Option Explicit
Dim xlApp
Dim xlBook
dim xlSheet
设置xlApp = Crea teObject（Excel.Application）
xlApp.Visible = False
xlApp.EnableEvents = False
xlApp.ScreenUpdating = False
'xlApp.Calculation = -4135'xlCalculationManual
set xlBook = xlApp.Workbooks.Open（C：\Users\wangCL\Desktop\data.xlsx）
set xlSheet = xlBook.Worksheets（data（4） ）
'CONTENT HERE
Dim count
Dim dataArray
Dim height
Dim width
Dim rWidth
Dim packArray
Dim i
Dim j
dim rowArray
dim ColumnInGroup
dim k
dim b
用xlSheet
.activate
ColumnInGroup = 4
height = .Cells（.Rows.count，1）.End（-4162） .Row
'假设第一行是标题
'从第二行开始
如果height> 1然后
对于i = 2要高度
width = .Cells（i，.Columns.count）.End（-4159）.Column
'round 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
'default value
rWidth = width
for j = 2 to width step ColumnInGroup
if 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
'rWidth = .Cells（i，1）.End（-4161）.Column
'如果.Cells（i，rWidth - 1）.Value =然后
'rWidth = 1
'End If
''检查每个新的T - 1
'如果rWidth Mod 3 = 0然后
'rWidth = rWidth + 1
'ElseIf rWidth Mod 3 = 1然后
'rWidth = rWidth
'ElseIf rWidth Mod 3 = 2然后
'rWidth = rWidth + 2
'End If
'如果没有打包
如果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
结束如果
结束
xlBook.save
xlApp.Quit
set xlSheet = nothing
set xlBook = nothing
set xlApp = nothing
msgbox完成
Is there any faster process to move the cell values in a group from right to left if any group of cells are blank using VBScript without using any Looping technique? (Packing the data of each row , to the left)
Input Table:*
Project# T1Name T1StartDate T1FinishDate T2Name T2StartDate T2FinishDate T3Name T3StartDate T3FinishDate
11 S1 12/7/2012 19/7/2012 S2 12/7/2012 19/7/2012
12 S2 12/6/2012
13 S4 11/05/12 S6 12/5/10
Output Table:
Project# T1Name T1StartDate T1FinishDate T2Name T2StartDate T2FinishDate T3Name T3StartDate T3FinishDate
11 S1 12/7/2012 19/7/2012 S2 12/7/2012 19/7/2012
12 S2 12/6/2012
13 S4 11/05/12 S6 12/05/10
Updated MY Output Table Please check,firstly it was got misplaced!
Update1
Project# T1Name T1StartDate T1FinishDate T2Name T2StartDate T2FinishDate T3Name T3StartDate T3FinishDate
10 S1 11/5/2011 S2 5/5/2011
11 S1 11/5/2011 5/4/2011 S1 11/5/2011 5/4/2011
Update2
Project# T1Name T1StartDate T1FinishDate T2Name T2StartDate T2FinishDate T3Name T3StartDate T3FinishDate
11 11/5/2011 S1 11/5/2011 5/4/2011 S2 11/5/2011 5/4/2011
Add this entry to the table it is not shifted properly. Can you check please?
Updated Code:
Option Explicit
Dim objExcel1,objWorkbook
Dim strPathExcel1
Dim objSheet1,IntRow1
Dim Task,Totltask
Dim DataArray(14),index,Counter
Set objExcel1 = CreateObject("Excel.Application")
strPathExcel1 = "D:\VA\TestVBSScripts\Test.xlsx"
Set objWorkbook=objExcel1.Workbooks.open(strPathExcel1)
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
IntRow1=2
Do While objSheet1.Cells(IntRow1,1).Value <> ""
Totltask=2
index=0
Do Until Totltask> 10
'MsgBox("Hi")
If objSheet1.Cells(IntRow1,Totltask).Value <> "" Or objSheet1.Cells(IntRow1,Totltask+1).Value <> "" Or objSheet1.Cells(IntRow1,Totltask+2).Value <> "" Then
DataArray(index)=objSheet1.Cells(IntRow1,Totltask).Value
DataArray(index+1)=objSheet1.Cells(IntRow1,Totltask+1).Value
DataArray(index+2)=objSheet1.Cells(IntRow1,Totltask+2).Value
index=index+3
End If
Totltask=Totltask+3
Loop
Totltask=2
Counter=index-1
index=0
'MsgBox(Counter)
Do While index < Counter
'MsgBox("Hi")
objSheet1.Cells(IntRow1,Totltask).Value=DataArray(index)
objSheet1.Cells(IntRow1,Totltask+1).Value=DataArray(index+1)
objSheet1.Cells(IntRow1,Totltask+2).Value=DataArray(index+2)
Totltask=Totltask+3
index=index+3
Loop
Erase DataArray
Do Until Totltask >10
objSheet1.Cells(IntRow1,Totltask).Value=""
Totltask=Totltask+1
Loop
IntRow1=IntRow1+1
Loop
'=======================
objExcel1.ActiveWorkbook.SaveAs strPathExcel1
objExcel1.Workbooks.close
objExcel1.Application.Quit
'======================
***Can any body suggest how should i make it more faster,If possible? This code is correct,producing output as desired.But too slow.
解决方案
EDIT:make the number of column in a group from 3 to N (ColumnInGroup)
EDIT: Fixed some bugs, and allow "NAME" field to be empty, a "T" type is treated as exist if either Name, start date, end date exist, improved performance by assigning back in ROW unit instead of cell unit
EDIT:Fixed a bug
EDIT:
I get the value of these constant in VBA, you open an excel, Alt + F11 to open VB Editor, Crtl + G open an immediate window, type ?xlUp , it will show the value of xlUp below
The Code Below is in VBS, works on the sheet you currently display and the performance should be okay... Change the Workbook full path, worksheet name to use
Option Explicit
Dim xlApp
Dim xlBook
dim xlSheet
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
xlApp.EnableEvents = False
xlApp.ScreenUpdating = False
'xlApp.Calculation = -4135 'xlCalculationManual
set xlBook = xlApp.Workbooks.Open("C:\Users\wangCL\Desktop\data.xlsx")
set xlSheet = xlBook.Worksheets("data (4)")
'CONTENT HERE
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 xlSheet
.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
width = .Cells(i, .Columns.count).End(-4159).Column
'round width
if (width -1 )mod columnInGroup <> 0 then
width = (((width -1)\columnInGroup )+1)* columnInGroup + 1
end if
if width > 1 then
'finding the last unit originally packed
redim rowArray(0,width-1)
rowArray = .range(.cells(i,1), .cells(i,width)).value
'default value
rWidth = width
for j = 2 to width step ColumnInGroup
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
'rWidth = .Cells(i, 1).End(-4161).Column
'If .Cells(i, rWidth - 1).Value = "" Then
' rWidth = 1
'End If
''check for each new "T" - 1
'If rWidth Mod 3 = 0 Then
' rWidth = rWidth + 1
'ElseIf rWidth Mod 3 = 1 Then
' rWidth = rWidth
'ElseIf rWidth Mod 3 = 2 Then
' rWidth = rWidth + 2
'End If
' if is not packed
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
xlBook.save
xlApp.Quit
set xlSheet = nothing
set xlBook = nothing
set xlApp = nothing
msgbox "Done"
这篇关于如果任何一组单元格使用VBScript空白而不使用任何循环技术，则可以从右到左移动组中的单元格值？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
