valor - seleccionar hoja excel vba

Para mover los valores de celda de un grupo de derecha a izquierda si algún grupo de celdas está vacío usando VBScript sin usar ninguna técnica de bucle?

Question

¿Hay algún proceso más rápido para mover los valores de celda de un grupo de derecha a izquierda si algún grupo de celdas está vacío usando VBScript sin utilizar ninguna técnica de bucle? (Embalaje de los datos de cada fila, a la izquierda)

Tabla de entrada: *

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   

Tabla de salida:

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

Tabla de salida MY actualizada Por favor, compruebe, en primer lugar, se extravió.

Actualización1

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   

Actualización2

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

Agregue esta entrada a la tabla, no está desplazada correctamente. ¿Puedes verificar por favor?

Código actualizado:

 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
 ''======================

*** ¿Puede algún cuerpo sugerir cómo debería hacerlo más rápido, si es posible? Este código es correcto y produce el resultado deseado. Pero es demasiado lento.

Answer 1

EDITAR: crea el número de columna en un grupo de 3 a N (ColumnInGroup)

EDITAR: corrigió algunos errores y permitió que el campo "NAME" esté vacío, un tipo "T" se trata como si existiera Nombre, fecha de inicio, fecha de finalización, rendimiento mejorado al asignar de nuevo en unidad ROW en lugar de unidad celular

EDIT: corrigió un error

EDITAR: Obtengo el valor de estas constantes en VBA, abre un Excel, Alt + F11 para abrir el Editor de VB, Crtl + G abre una ventana inmediata, escribe ?xlUp , mostrará el valor de xlUp a continuación

El código a continuación está en VBS, funciona en la hoja que visualiza actualmente y el rendimiento debería ser correcto ... Cambie la ruta completa del libro de trabajo, el nombre de la hoja de trabajo para usar

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"

Answer 2

Sugiero usar el método Delete de Excel.Range para eliminar las celdas vacías y pasar un parámetro para desplazar las celdas restantes a la izquierda:

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