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

更新された 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

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

適切にシフトされていないテーブルにこのエントリを追加します。確認していただけますか？

更新されたコード:

 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

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 に答える
1

EDIT：グループ内の列数を3からNにする（ColumnInGroup）

編集: いくつかのバグを修正し、「NAME」フィールドを空にできるようにしました。名前、開始日、終了日のいずれかが存在する場合、「T」タイプは存在するものとして扱われ、セル単位ではなく ROW 単位で代入することでパフォーマンスが向上しました

編集：バグを修正

編集: VBA でこれらの定数の値を取得します。Excel を開き、 Alt + F11VB エディターを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 に答える