如果任何一组单元格使用 VBScript 在不使用任何循环技术的情况下为空白,是否有更快的过程将组中的单元格值从右向左移动?(将每行的数据打包到左侧)
输入表: *
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
输出表:
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
更新了 MY 输出表请检查,首先它放错地方了!
更新1
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
更新2
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
将此条目添加到表中,它未正确移动。你能检查一下吗?
更新的代码:
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:VATestVBSScriptsTest.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
'======================
如果可能的话,任何人都可以建议我应该如何让它更快吗?此代码是正确的,根据需要生成输出。但太慢了。
编辑:使组中的列数从 3 到 N (列在组)
编辑:修复了一些错误,并允许"NAME"字段为空,如果名称,开始日期,结束日期存在,则"T"类型被视为存在,通过分配回ROW单元而不是单元格单元来提高性能
编辑:修复了一个错误
编辑:我在 VBA 中得到这些常量的值,您打开一个 excel,Alt + F11
打开 VB 编辑器,Crtl + G
打开一个即时窗口,键入 ?xlUp
,它将在下面显示 xlUp 的值
下面的代码在VBS中,适用于您当前显示的工作表而且性能应该还可以...更改要使用的工作簿完整路径、工作表名称
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:UserswangCLDesktopdata.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"
我建议使用 Delete
Excel.Range
方法来删除空单元格,并传递一个参数将剩余单元格向左移动:
Option Explicit
Dim xlApp, xlBook, xlSheet
Dim rowCount, columnCount, i, j, currentColumnCount
Dim rng, cell, hasValue
Const xlShiftToLeft = -4159
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("C:pathtoexcelfile.xlsx")
Set xlSheet = xlBook.Worksheets("WorksheetName")
rowCount = xlSheet.UsedRange.Rows.Count
columnCount = xlSheet.UsedRange.Columns.Count - 3
For i = 2 To rowCount
currentColumnCount = columnCount
j = 2
Do While j <= currentColumnCount
Set rng = xlSheet.Range(xlSheet.Cells(i,j), xlSheet.Cells(i,j+2))
hasValue = False
For Each cell In rng.Cells
If cell.Value <> "" Then
hasValue = True
Exit For
End If
Next
If hasValue Then
j = j + 3
Else
rng.Delete xlShiftToLeft
currentColumnCount = currentColumnCount - 3
End If
Loop
Next
xlBook.Save
xlApp.Quit