View Full Version : Unmerge cells & copy line from above
Hoopsah
08-01-2008, 02:57 AM
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
08-01-2008, 03:26 AM
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
08-01-2008, 03:41 AM
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
08-01-2008, 04:09 AM
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
08-01-2008, 04:49 AM
When I ran the macro it only unmerged the cells (???)
Bob Phillips
08-01-2008, 04:57 AM
Can you post a workbook to take a look at Gerry?
Hoopsah
08-01-2008, 06:01 AM
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
08-01-2008, 06:27 AM
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
08-01-2008, 06:43 AM
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
08-01-2008, 06:56 AM
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
08-01-2008, 06:56 AM
Sorry must have clicked twice
Hoopsah
08-01-2008, 06:59 AM
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
08-01-2008, 07:15 AM
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
08-05-2008, 04:32 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.