Unmerge cells & copy line from above

[Hoopsah]

Hi

Just looking for a quick macro is possible.

I have a spreadsheet that has numerous lines. A lot of the cells have been merged also.

What I would like is a macro that will unmerge the entire worksheet and then go to all the blank lines and copy from the cell directly above it.

I started trying to do this but already my code is longer than this page.

Any help would be appreciated

Cheers Guys

Hoopsah

[Bob Phillips]

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim rng As Range

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With ActiveSheet

.Cells.MergeCells = False
Set rng = .UsedRange
LastRow = rng(rng.Count).Row
For i = 2 To LastRow

If Application.CountA(.Rows(i)) = 0 Then

.Rows(i - 1).Copy .Cells(i, "A")
End If
Next i
End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

[Hoopsah]

Hi Bob,

thanks for that,

When I run the code it unmerges all the cells, but I need it to copy the line above also,

Is that possible?

I have been using this so far - and it works, but it is very slow.

Option Explicit
Sub unmerge_fill_values()

'unmerge and put value in mergearea
'EXAMPLE
'START WITH
'D1:E3 merged, value = "abc"
'RESULT
'D1:E3 unmerged, D1, D2, D3, E1, E2, E3 get "abc"
Dim LR As Long 'Last Row
Dim LC As Integer 'Last Column
Dim i As Long
Dim j As Integer
Dim mergeRng As Range
Dim checkmerged As Boolean
Dim AppSetCalc As Integer
With Application
.ScreenUpdating = False
AppSetCalc = .Calculation
.Calculation = xlCalculationManual
End With
With ActiveSheet
'needing xlCellTypeLastCell: else if last cell is merged wrong area will be found
LR = .Cells.SpecialCells(xlCellTypeLastCell).Row
LC = .Cells.SpecialCells(xlCellTypeLastCell).Column
With .Cells(LR, LC)
If .MergeCells Then
LR = LR + .MergeArea.Rows.Count - 1
LC = LC + .MergeArea.Columns.Count - 1
End If
End With
If .Range(.Cells(1, 1), .Cells(LR, LC)).MergeCells = False Then
MsgBox "no merged cells on this sheet", 48, "EXIT"
Exit Sub
End If
For i = 1 To LR
On Error Resume Next
checkmerged = .Range(.Cells(i, 1), .Cells(i, LC)).MergeCells
'error occurs when MergeArea intersects row and contains more rows
'checkmerged is TRUE when MergeArea is in one row
If Err Or checkmerged Then
Err.Clear
For j = 1 To LC
With .Cells(i, j)
Set mergeRng = .MergeArea
.UnMerge
mergeRng = .Value
End With
Next j
End If
Next i

End With
With Application
.ScreenUpdating = True
.Calculation = AppSetCalc
End With
End Sub

[Bob Phillips]

Doesn't this bit



For i = 2 To LastRow

If Application.CountA(.Rows(i)) = 0 Then

.Rows(i - 1).Copy .Cells(i, "A")
End If
Next i


do just that?

[Hoopsah]

When I ran the macro it only unmerged the cells (???)

[Bob Phillips]

Can you post a workbook to take a look at Gerry?

[Hoopsah]

Hi Bob,

I have attached a sample of the file.

I have included a click button with the macro you supplied,

Cheers Bob

Gerry

[Bob Phillips]

Gerry,

I am thinking that it might be a simple terminology issue.

When you said go along the blank lines and copy from above. I assumed that you meant where the whole line was blank, but did you actually mean any blank cells in a line? If so, it will be slow!

[Hoopsah]

Ahh!

Your right Bob, I did mean whenever a cell was blank then copy from above.

No problem then, the code that I have used works but is really slow (This was just a sample of the date, real mccoy is about 20,000 lines)

Guess I'll just have to start it and go get a cup of tea

Thanks again for your help Bob,

Cheers

Gerry

[Bob Phillips]

I have a version, maybe faster than yours but I have one question.

On line 13 say, the Autocode/Project Id is blank, although it is not merged with the above. Should that be blank afte this process or inherit the value above (I assumed you are trying to make this into a mor analysable format).

[Hoopsah]

Sorry must have clicked twice

[Hoopsah]

Again your right, I never thought of that at all.

No, if the cell is blank before the un-merging it really should remain blank afterwards.

I thought for a moment that this would be nice and easy, then you come in with your spanner....lol

Back to the drawing board I think!

[Bob Phillips]

Mine looks to take a similar approach to yours, but was about twice as fast on my machine



Public Sub ProcessData()
Dim cell As Range
Dim MergedCell As Range
Dim NumRows As Long
Dim NumCols As Long

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With ActiveSheet

For Each cell In Range("A1").Resize( _
.Cells.SpecialCells(xlCellTypeLastCell).Row, _
.Cells.SpecialCells(xlCellTypeLastCell).Column)

If cell.MergeCells Then

NumRows = cell.MergeArea.Rows.Count
NumCols = cell.MergeArea.Columns.Count
cell.UnMerge
If NumRows > 1 Then cell.AutoFill cell.Resize(NumRows)
If NumCols > 1 Then cell.Resize(NumRows).AutoFill cell.Resize(NumRows, NumCols)
End If
Next cell
End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub


Both your and mine left the prior blanks alone as required.

[Hoopsah]

Hi Bob,

ok, yours is faster on my machine too, I have amended my macro - cheers again for your help.

P.S. MDMAcKillop helped and took the attachment away,

Cheers

Gerry