Move cell values ​​in a group from right to left if any group of cells is empty using VBScript without using any Looping technique?

Question

Is there a faster process for moving cell values ​​in a group from right to left if any group of cells is empty using VBScript without using any Looping technique? (Packing data for each row, 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 table MY Output Please check, firstly, it was lost!

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 record to the table so that it does not move 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 I can make it faster, if possible? This code is correct, producing output as desired. But too slow.

Answer 1

EDIT: enter the number of columns in the group from 3 to N (ColumnInGroup)

EDIT: Some bugs are fixed and an empty "NAME" field is allowed, the type "T" is considered as existing if there is a name, start date, end date, improved performance, assigning a block instead of a cell to the ROW unit

EDIT: bug fixed

EDIT: I get the value of these constants in VBA, you open excel, Alt + F11 to open the VB Editor, Crtl + G open the nearest window, enter ?xlUp , it will show the xlUp value below

The code below is in VBS, it works on the sheet that you are showing now and the performance should be fine ... Change the full path of the book, the name of the worksheet 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" 

Answer 2

I suggest using the Delete Excel.Range method to remove empty cells and passing a parameter to shift the remaining cells to the left:

 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