0

如果任何一组单元格使用 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

更新了我的输出表 请检查，首先它放错地方了！

更新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:\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
 '======================

***如果可能的话，任何机构都可以建议我应该如何让它更快？这段代码是正确的，可以根据需要产生输出。但是太慢了。

4

2 回答 2

1

编辑：使组中的列数从 3 到 N (ColumnInGroup)

编辑：修复了一些错误，并允许“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:\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"
于 2012-12-13T06:05:52.590 回答
1

我建议使用删除空单元格的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:\path\to\excel\file.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
于 2012-12-18T09:37:15.453 回答