Combining Broken Ranges of Cells In One Contiguous Range

[Ark68]

Hi folks,
I am struggling to think of an effective/efficient VBA method to accomplish this particular task. I have a range of cells (A3:BG3). This range is comprised of 8 clusters of 7 cells. Their values are dynamic, in that with each execution of a macro will change. Changes are always in clusters of 7, and it wouldn't be unusual to have clusters of empty cells. Cells See the "BEFORE" sample below. (Row 1 is header)

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ	BA	BB	BC	BD	BE	BF	BG
1	BEFORE
2	R1-A	R1-B	R1-C	R1-D	R1-E	R1-F	R1-G	R2-A	R2-B	R2-C	R2-D	R2-E	R2-F	R2-G	R3-A	R3-B	R3-C	R3-D	R3-E	R3-F	R3-G	R4-A	R4-B	R4-C	R4-D	R4-E	R4-F	R4-G	R5-A	R5-B	R5-C	R5-D	R5-E	R5-F	R5-G	R6-A	R6-B	R6-C	R6-D	R6-E	R6-F	R6-G	R7-A	R7-B	R7-C	R7-D	R7-E	R7-F	R7-G	R8-A	R8-B	R8-C	R8-D	R8-E	R8-F	R8-G	Cell BE	Cell BF	Cell GB
3									HPE	HEP	HPE	RPE	WPE	CUE	CUE1							WPL	WPL	WPL	WPL	RPE	RPL	RPE								CUE	RPE	RPE	RPE	CUE	CUE	WPL	HPE	HEP	HPE	RPE	WPE	CUE	CUE1								These	cells	can't move
Sheet1

Below is what I am looking for a VBA solution to do. I need to shift all used clusters right so that all data is contiguous in row 2 (i no gaps). Note that the Values beyond and including cell BE cannot move.

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ	BA	BB	BC	BD	BE	BF	BG
6	AFTER
7	R1-A	R1-B	R1-C	R1-D	R1-E	R1-F	R1-G	R2-A	R2-B	R2-C	R2-D	R2-E	R2-F	R2-G	R3-A	R3-B	R3-C	R3-D	R3-E	R3-F	R3-G	R4-A	R4-B	R4-C	R4-D	R4-E	R4-F	R4-G	R5-A	R5-B	R5-C	R5-D	R5-E	R5-F	R5-G	R6-A	R6-B	R6-C	R6-D	R6-E	R6-F	R6-G	R7-A	R7-B	R7-C	R7-D	R7-E	R7-F	R7-G	R8-A	R8-B	R8-C	R8-D	R8-E	R8-F	R8-G	Cell BE	Cell BF	Cell GB
8	HPE	HEP	HPE	RPE	WPE	CUE	CUE1	WPL	WPL	WPL	WPL	RPE	RPL	RPE	CUE	RPE	RPE	RPE	CUE	CUE	WPL	HPE	HEP	HPE	RPE	WPE	CUE	CUE1																													These	cells	can't move
Sheet1

Any support or hinting would be greatly appreciated. Thank you all in advance.

 

[Marcelo Branco]

Maybe something like this

Sub aTest()
    Dim vBefore As Variant, vAfter() As Variant
    Dim i As Long, j As Long, lCols As Long
    
    vBefore = Range("A3:BD3")
    lCols = UBound(vBefore, 2)
    ReDim vAfter(1 To lCols)
        
    'loop and store non blank values
    For i = 1 To lCols
        If vBefore(1, i) <> "" Then
            j = j + 1
            vAfter(j) = vBefore(1, i)
        End If
    Next i
    'Transfer the array
    Range("A3:BD3") = vAfter
End Sub

Hope this helps

M.

 

[offthelip]

try this code:

Sub test()
inarr = Range("A3:BD3")
Range("A3:BG3") = ""
outarr = Range("A3:BD3")
ii = 1
For i = 1 To 56
  If inarr(1, i) <> "" Then
   outarr(1, ii) = inarr(1, i)
   ii = ii + 1
  End If
Next i
Range("A3:BD3") = outarr

End Sub

 

[Fluff]

Another option

Sub Ark()
   Dim Rng As Range
   Dim a As Variant
   Dim x As Long
   
   For Each Rng In Range("A3:BD3").SpecialCells(xlConstants).Areas
      If Rng.Column <> 1 Then
         a = Rng
         Rng.ClearContents
         If Range("A3").Value = "" Then x = 0 Else x = 1
         Rng.End(xlToLeft).Offset(, x).Resize(, Rng.Count).Value = a
      End If
   Next Rng
End Sub

 

[Ark68]

Thank you all for your suggestions. They are far neater than my approach!
I haven't had a chance yet to test, but wanted to ensure I acknowledged your efforts. I will be back!

 

[Fluff]

Ok,