Combining Broken Ranges of Cells In One Contiguous Range

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,976
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAVAWAXAYAZBABBBCBDBEBFBG
1BEFORE
2R1-AR1-BR1-CR1-DR1-ER1-FR1-GR2-AR2-BR2-CR2-DR2-ER2-FR2-GR3-AR3-BR3-CR3-DR3-ER3-FR3-GR4-AR4-BR4-CR4-DR4-ER4-FR4-GR5-AR5-BR5-CR5-DR5-ER5-FR5-GR6-AR6-BR6-CR6-DR6-ER6-FR6-GR7-AR7-BR7-CR7-DR7-ER7-FR7-GR8-AR8-BR8-CR8-DR8-ER8-FR8-GCell BECell BFCell GB
3HPEHEPHPERPEWPECUECUE1WPLWPLWPLWPLRPERPLRPECUERPERPERPECUECUEWPLHPEHEPHPERPEWPECUECUE1These cellscan'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
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAVAWAXAYAZBABBBCBDBEBFBG
6AFTER
7R1-AR1-BR1-CR1-DR1-ER1-FR1-GR2-AR2-BR2-CR2-DR2-ER2-FR2-GR3-AR3-BR3-CR3-DR3-ER3-FR3-GR4-AR4-BR4-CR4-DR4-ER4-FR4-GR5-AR5-BR5-CR5-DR5-ER5-FR5-GR6-AR6-BR6-CR6-DR6-ER6-FR6-GR7-AR7-BR7-CR7-DR7-ER7-FR7-GR8-AR8-BR8-CR8-DR8-ER8-FR8-GCell BECell BFCell GB
8HPEHEPHPERPEWPECUECUE1WPLWPLWPLWPLRPERPLRPECUERPERPERPECUECUEWPLHPEHEPHPERPEWPECUECUE1These cellscan't move
Sheet1


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

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

Marcelo Branco

MrExcel MVP
Joined
Aug 23, 2010
Messages
16,687
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Maybe something like this

VBA Code:
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

Well-known Member
Joined
Dec 23, 2017
Messages
1,909
Office Version
  1. 2010
Platform
  1. Windows
try this code:
VBA 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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
60,323
Office Version
  1. 365
Platform
  1. Windows
Another option
VBA Code:
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

Well-known Member
Joined
Mar 23, 2004
Messages
3,976
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
60,323
Office Version
  1. 365
Platform
  1. Windows

Forum statistics

Threads
1,137,125
Messages
5,679,773
Members
419,855
Latest member
Eddier32

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top