Unmerge Cells & Copy Cells Down to Next Line of Data

[t0mato]

Hello!

I have a (what I believe to be) fairly simple request I am looking to achieve with Excel VBA.

Please see attached report.

I am simply looking to unmerge each grouped cell in column D (Org Level 3) and copy the first line down to the next line. See images below:

Current State:
29283

Goal State:
29284


Simply put, the macro/VBA code should unmerge the data in column D and copy the first line down to the last line until the data changes, and loop for each area to the bottom of the data. Additionally, you will notice in line 1227 where column A is "Warehouse" - the code should disregard this section since the column D is not grouped. I.e., stop where the column A line = "warehouse".

I am planning to macro record the unmerge of the first group starting at the top and try to have it loop until it reaches warehouse then stop but am not exactly sure how to write this.

Thanks so much for the help!

[Paul_Hossler]

Try this




Option Explicit


Sub UnmergeAndFill()
Dim rowLast As Long, i As Long
Dim aryAreas() As Range
Dim cntAreas As Long

With Worksheets("HIN")
rowLast = .Cells(.Rows.Count, 4).End(xlUp).Row


i = 2
Do While i <= rowLast
If .Cells(i, 4).MergeCells Then
cntAreas = cntAreas + 1
ReDim Preserve aryAreas(1 To cntAreas)
Set aryAreas(cntAreas) = .Cells(i, 4).MergeArea
End If

i = .Cells(i, 4).End(xlDown).Row
Loop


For i = LBound(aryAreas) To UBound(aryAreas)
aryAreas(i).UnMerge
aryAreas(i).Value = aryAreas(i).Cells(1, 1).Value
Next i
End With


MsgBox "Done"


End Sub

[t0mato]

This works perfectly, thanks so much!

[t0mato]

How would I modify this to iterate through all sheets in the workbook (there are 25), except for the first sheet (which is an instruction sheet).

I've tried the following (not sure how to exclude the first sheet so I figured i'd just have it run anyway, through the sheet doesnt have any numbers) but this doesn't work, it doesn't even return an error:


Public Sub IterateSheets()Dim S As Integer
S = 1
Do While S = Worksheets.Count
Worksheets(S).Select
UnmergeAndFill
S = S + 1
Loop
End Sub

Public Sub UnmergeAndFill()
' Unmerge and Fill
Dim rowLast As Long, i As Long
Dim aryAreas() As Range
Dim cntAreas As Long
rowLast = .Cells(.Rows.Count, 4).End(xlUp).Row
i = 2
Do While i <= rowLast
If .Cells(i, 4).MergeCells Then
cntAreas = cntAreas + 1
ReDim Preserve aryAreas(1 To cntAreas)
Set aryAreas(cntAreas) = .Cells(i, 4).MergeArea
End If
i = .Cells(i, 4).End(xlDown).Row
Loop
For i = LBound(aryAreas) To UBound(aryAreas)
aryAreas(i).UnMerge
aryAreas(i).Value = aryAreas(i).Cells(1, 1).Value
Next i
End With
' Unmerge and fill
End Sub

[Paul_Hossler]

Option Explicit


Sub UnmergeAndFill()
Dim rowLast As Long, i As Long
Dim aryAreas() As Range
Dim cntAreas As Long
Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
With ws
If .Name = "Instructions" Then GoTo NextSheet

Erase aryAreas
ReDim aryAreas(1 To 1)
cntAreas = 0

rowLast = .Cells(.Rows.Count, 4).End(xlUp).Row

i = 2
Do While i <= rowLast
If .Cells(i, 4).MergeCells Then
cntAreas = cntAreas + 1
ReDim Preserve aryAreas(1 To cntAreas)
Set aryAreas(cntAreas) = .Cells(i, 4).MergeArea
End If

i = .Cells(i, 4).End(xlDown).Row
Loop


For i = LBound(aryAreas) To UBound(aryAreas)
aryAreas(i).UnMerge
aryAreas(i).Value = aryAreas(i).Cells(1, 1).Value
Next i
End With


NextSheet:
Next


MsgBox "Done"
End Sub

[t0mato]

Hello! Thanks for the help. This returns an error, however.

29340

29341

Any ideas on this?

[Paul_Hossler]

It works OK when the worksheets have the proper format (see attachment), so I'm guessing that a worksheet is formatted differently

Add the marked line and see which worksheet caused the issue and maybe attach a workbook with just the problematic worksheet




With ws

MsgBox .Name ' <<<<<<<<<<<<<<<<<<<<<<<

If .Name = "Instructions" Then GoTo NextSheet

[t0mato]

I've attached the updated workbook (with multiple sheets) here.

The code below works perfectly, I just need it to iterate through all sheets (excluding "Instructions") in the workbook (there are 25, I just included a few).


Public Sub UnmergeAndFill()

Dim rowLast As Long, i As Long
Dim aryAreas() As Range
Dim cntAreas As Long

With Worksheets("Raw Data")
rowLast = .Cells(.Rows.Count, 4).End(xlUp).Row




i = 2

Do While i <= rowLast
If .Cells(i, 4).MergeCells Then
cntAreas = cntAreas + 1
ReDim Preserve aryAreas(1 To cntAreas)
Set aryAreas(cntAreas) = .Cells(i, 4).MergeArea
End If

i = .Cells(i, 4).End(xlDown).Row
Loop


For i = LBound(aryAreas) To UBound(aryAreas)
aryAreas(i).UnMerge
aryAreas(i).Value = aryAreas(i).Cells(1, 1).Value
Next i
End With


End Sub




Thanks again for the help!

[georgiboy]

That should be:


Public Sub UnmergeAndFill() Dim rowLast As Long, i As Long
Dim aryAreas() As Range
Dim cntAreas As Long
Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "Instructions" Then
rowLast = .Cells(.Rows.Count, 4).End(xlUp).Row
i = 2
Do While i <= rowLast
If .Cells(i, 4).MergeCells Then
cntAreas = cntAreas + 1
ReDim Preserve aryAreas(1 To cntAreas)
Set aryAreas(cntAreas) = .Cells(i, 4).MergeArea
End If
i = .Cells(i, 4).End(xlDown).Row
Loop
For i = LBound(aryAreas) To UBound(aryAreas)
aryAreas(i).UnMerge
aryAreas(i).Value = aryAreas(i).Cells(1, 1).Value
Next i
End If
End With
Next ws
End Sub

[Paul_Hossler]

I've attached the updated workbook (with multiple sheets) here.

The code below works perfectly, I just need it to iterate through all sheets (excluding "Instructions") in the workbook (there are 25, I just included a few).

Thanks again for the help!

I believe that the macro from my Post#5 already does what you want.

The 'For Each' loops through all WS

The If .Name ... skips 'Instructions'



For Each ws In ThisWorkbook.Worksheets
With ws

If .Name = "Instructions" Then GoTo NextSheet


Using the sample XLSX from your post #8, it ran to completion without error


Since you changed the above to a specific worksheet, it would not do all sheets


With Worksheets("Raw Data")

[georgiboy]

Sorry Paul, missed that...

[Paul_Hossler]

:thumb

[t0mato]

You're right! It does work.. I was just adding the code to the wrong module (sorry I'm new to this). I made it a Public code and saved it to my PERSONAL project. When running from there, I get the error mentioned above. I thought in making it Public I could run it in any workbook? In other words, I get the error when I add the macro/module to my PERSONAL project. When I add it to the currently opened workbook, it works fine.

[Paul_Hossler]

Then use


... In ActiveWorkbook.Worksheets

and not


... In ThisWorkbook.Worksheets

Excel can only do what you tell it to do :devil2:

[t0mato]

Wow. I am still very much a VBA novice (obviously) with only one course under my belt. Still a lot to learn clearly.

If I want to apply filters to each sheet, I think I would need to add the autofilter clause somewhere within the loop. Any ideas on where this should be added? Is it Selection.Autofilter? Will it need to be in a separate loop?

[Paul_Hossler]

If I want to apply filters to each sheet, I think I would need to add the autofilter clause somewhere within the loop.

Probably

That could be a little tricky

More details and an example would be helpful

[t0mato]

Thanks again for all of the help. I'd just like to add the filter buttons (Ctrl + shift + L) to each sheet. So once it does the unmerge & fill, just apply filter buttons to the columns. Let me know if further information is needed!

[Paul_Hossler]

I don't have any unmodified data to test with, but I think just adding the last line would do it



For i = LBound(aryAreas) To UBound(aryAreas) aryAreas(i).UnMerge
aryAreas(i).Value = aryAreas(i).Cells(1, 1).Value
Next i

If Not .AutoFilterMode Then .Rows(1).AutoFilter

[t0mato]

This works perfectly. Thanks for all of the help!

I do have one final question with this. If I wanted to apply the same process to different columns, where is the code would this be adjusted? Right now it is doing the merge & unfill on column C. I now need it to apply to columns A-F. I've done my best to find where it defines to apply to column C so that I may adjust accordingly but cannot figure it out.

Any help here would be greatly appreciated!

[Paul_Hossler]

Like this?




Option Explicit


Sub UnmergeAndFill()
Dim r As Long, c As Long
Dim rData As Range
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Instructions" Then GoTo NextSheet

ws.Range("A:F").UnMerge

Set rData = ws.Cells(1, 1).CurrentRegion

With rData
For r = 3 To .Rows.Count
For c = 1 To 6
If Len(.Cells(r, c).Value) = 0 Then .Cells(r, c).Value = .Cells(r - 1, c).Value
Next c
Next r
End With

If Not ws.AutoFilterMode Then ws.Rows(1).AutoFilter


NextSheet:
Next


MsgBox "Done"
End Sub

[t0mato]

Paul, that is exactly it. Just trying to wrap my head around the change here.

Thanks again!

[snb]

I used the file in your first post:

This is all you need for the first 4 columns:


Sub M_snb()
Sheet1.Cells.UnMerge

For Each it In sheet1.Columns(1).Resize(, 4).SpecialCells(4).Areas
it.Value = it.Offset(-1).Cells(1).Resize(, it.Columns.Count).Value
Next
End Sub

For the first 4 columns in all sheets in the active workbook:

Sub M_snb()
For Each sh In Sheets
sh.Cells.UnMerge

If sh.Name <> "Instructions" Then
For Each it In sh.Columns(1).Resize(, 4).SpecialCells(4).Areas
it.Value = it.Offset(-1).Cells(1).Resize(, it.Columns.Count).Value
Next
End If
Next
End Sub

NB. You should never use merged cells.

[Paul_Hossler]

@snb --

1. I like your more efficient way, but this below eliminates the .Areas loop



Option Explicit


Sub UnmergeAndFill()
Dim rData As Range, rBlanks As Range
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Instructions" Then GoTo NextSheet

ws.Range("A:F").UnMerge

On Error GoTo NextSheet
Set rData = ws.Cells(1, 1).CurrentRegion
Set rBlanks = rData.SpecialCells(xlCellTypeBlanks)
rBlanks.FormulaR1C1 = "=R[-1]C"
rData.Value = rData.Value
On Error GoTo 0

If Not ws.AutoFilterMode Then ws.Rows(1).AutoFilter


NextSheet:
Next


MsgBox "Done"
End Sub




2.
NB. You should never use merged cells.


IMVHO, 'Never' is mostly correct, but I'd agree that 97% of the time merged cells only cause trouble

[snb]

@PH

Yes it does eliminate.
But it takes more calculations.
I am not an adversary to loops, which I am to 'GoTo'-statements.
And almost equally to unnecessary Object variables:


with ws.Cells(1, 1).CurrentRegion.SpecialCells(4)
.Value = "=R[-1]C"
.Value = .Value
end with

[Paul_Hossler]

@PH

Yes it does eliminate.
But it takes more calculations.
I am not an adversary to loops, which I am to 'GoTo'-statements.
And almost equally to unnecessary Object variables:


with ws.Cells(1, 1).CurrentRegion.SpecialCells(4)
.Value = "=R[-1]C"
.Value = .Value
end with



1. Well, the only advantage I see to my 'unnecessary Object variables' is that my way works without generating a lot of #N/A errors

29527

Using the original Test_Unmerge2.xlsx as input, and adding your .Value snippet to the Unmerging and error checking and "Instructions" test



2. I don't see any significant increase in calculations, and I've found that sometimes, and in very specific circumstances, a GoTo can make code more readable without turning it into a plate of spaghetti




Sub UnmergeAndFill_snb()
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Instructions" Then GoTo NextSheet

ws.Range("A:F").UnMerge

On Error GoTo NextSheet

'snb -----------------------------------------------------------
With ws.Cells(1, 1).CurrentRegion.SpecialCells(4)
.Value = "=R[-1]C"
.Value = .Value
End With
'snb -----------------------------------------------------------

On Error GoTo 0

If Not ws.AutoFilterMode Then ws.Rows(1).AutoFilter
NextSheet:
Next

MsgBox "Done"
End Sub

[snb]

Here you go:


Sub M_snb()
For Each it In Sheets
If it.Name <> "Instructions" Then
it.Cells.UnMerge

With it.Cells(1).CurrentRegion.Resize(, 4)
.SpecialCells(4) = "=R[-1]C"
.Copy
.PasteSpecial -4163
End With
End If
Next

Application.CutCopyMode = False
End Sub

No pasta, rigatoni, farfalle, tagliatelle or spaghetti.