I am writing a VBA script that will delete (clear content) of the entire row if one of the cells within the rows is found to be blank or does not have any text or integer value.
I'm almost there, but I think my code is stuck in the for loop. Please let me know how I can further improve my code.
Sub Remove_Rows_BlankData()
For SheetCount = 1 To Sheets.Count 'SHEET LEVEL
Sheets(SheetCount).Visible = True
Sheets(SheetCount).Select
StartRow = 2
' EndRow = Cells(ActiveSheet.UsedRange.Rows.Count, 34)
LastRow = ActiveSheet.UsedRange.Rows.Count
LastCol = ActiveSheet.UsedRange.Columns.Count
Dim myRange As Range
Set myRange = Range(Cells(StartRow, 1), Cells(LastRow, LastCol))
'REMOVE ROWS W/ ANY BLANK CELLS
Dim DRow As Variant ' Sets DRow = Row w/ Blank
'From start row to last row
Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Select
Selection.ClearContents
Next
End Sub
I've rewritten your sub to avoid having to Select a worksheet in order to use it. By referencing each worksheet in the loop using a With ... End With statement, the cells and properties of each worksheet can be dealt with without resorting to selecting¹ the worksheet just to use the inherent association of the ActiveSheet.
Sub Remove_Rows_BlankData()
Dim ws As Long, fr As Long, lr As Long, lc As Long
On Error Resume Next 'just in case there are no blank cells
For ws = 5 To Worksheets.Count 'SHEET LEVEL
With Worksheets(ws)
.Visible = True
'Sheets(SheetCount).Select 'not necessary to select in order to process
fr = 2
' EndRow = Cells(ActiveSheet.UsedRange.Rows.Count, 34)
lr = .UsedRange.Rows.Count
lc = .UsedRange.Columns.Count
With .Range(.Cells(fr, 1), .Cells(lr, lc))
.SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
End With
End With
Next ws
End Sub
Note that no variables are created (aka Dim) within the loop; only reassigned values.
¹ See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
Related
This is a code that goes through the cells in column B in sheet2. If it finds a value that is not a date in column B, then it copies it, pastes it another sheet called 'errors' and then deletes that row from Sheet2. Whenever I try to run this, however, I get a 'Compile Error: Sub or function not defined'. I saw some other posts on this, but nothing mentioned there seemed to work for me.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheet("Errors").CountA("A1:A100")
For Each i In Worksheet("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheet("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
There are a few other errors/changes that could be made within the script
Add s to Worksheet
Use Option Explicit at top of code
Application.WorksheetFunction.CountA
Add range as argument to Counta i.e. Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Ensure correct ranges being worked with by wrapping in With Worksheets("Sheet2")
Determine last row by coming up from bottom of sheet with .Cells(.Rows.Count, "A").End(xlUp).Row, or you could end up looping to bottom of sheet
Correct syntax for delete line: i.EntireRow.Delete
You can put copy paste on one line: .Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
Be wary of using End(xlToRight) in cases of potentially ending up at far right of sheet.
Optimize code by switching some things off e.g. prevent repaint by switching off screen-updating during looping
Gather ranges to delete with Union and delete in 1 go or loop backwards to delete
VBA:
Option Explicit
Public Sub removeerrors()
Dim i As Range, x As Double, loopRange As Range, lastRow As Long, unionRng As Range
x = Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Application.ScreenUpdating = False
With Worksheets("Sheet2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set loopRange = .Range("A2:A" & lastRow)
If lastRow = 1 Then Exit Sub
For Each i In loopRange
If Not IsDate(i.Offset(0, 1)) Then
.Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, i)
Else
Set unionRng = i
End If
End If
Next i
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
You just need to change Worksheet to Worksheets with 's' at the end.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
For Each i In Worksheets("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheets("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
use fully qualified range references
loop backwards when deleting rows
update target sheet pasting row index
as follows
Option Explicit
Sub removeerrors()
Dim iRow As Long
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
With Worksheets("Sheet2") ' referecne "Sheet2" sheet
With .Range(.Range("A2"), .Range("A2").End(xlDown)) ' reference referenced sheet range from cell A2 down to next not empty one
For iRow = .Rows.Count To 1 Step -1 ' loop reference range backwards from its last row up
If Not IsDate(.Cells(iRow, 2)) Then ' if referenced range cell in column B current row is not a date
.Range(.Cells(iRow, 1), .Cells(iRow, 1).End(xlToRight)).Copy Destination:=Worksheets("Errors").Range("A1").Offset(x, 0) ' copy referenced range current row spanning from column A to next not empty column and paste it to sheet "Errors" column A row x
x = x + 1 ' update offset
.Rows(1).EntireRow.Delete ' delete referenced range current row
End If
Next
End With
End With
End Sub
This question already has answers here:
Excel VBA - Delete Rows Based on Criteria
(2 answers)
Closed 4 years ago.
In Excel, I want to delete entire row if a cell is blank.
This should count for A17:A1000.
Running the script it returns the error:
Run-time 1004 error
Method Range of object global failed
If I replace A17:A1000 with A it deletes some rows.
Sub DeleteBlanks()
Dim r As Long
Dim m As Long
Application.ScreenUpdating = False
m = Range("A17:A1000" & Rows.Count).End(xlUp).Row
For r = m To 1 Step -1
If Range("A17:A1000" & r).Value = "" Or Range("A17:A1000" & r).Value = 0 Then
Range("A17:A1000" & r).EntireRow.Delete
End If
Next r
Application.ScreenUpdating = True
End Sub
The main issue in your code is that it is counting wrong.
"A17:A1000" & r does not count the rows up but appends the number r to that string. So eg if r = 500 it will result in "A17:A1000500" but not in "A17:A1500" as you might expected.
To delete all rows where column A has a blank cell you can use
Option Explicit
Public Sub DeleteRowsWithBlankCellsInA()
Worksheets("Sheet1").Range("A17:A1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
This one deletes all blank lines at once and therefore is pretty fast. Also it doesn't need to disable ScreenUpdating because it is only one action.
Or if blank and zero cells need to be deleted use
Option Explicit
Public Sub DeleteRowsWithBlankOrZeroCellsInA()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define which worksheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = LastRow To 1 Step -1
If ws.Cells(iRow, "A").Value = vbNullString Or ws.Cells(iRow, "A").Value = 0 Then
ws.Rows(iRow).Delete
End If
Next iRow
End Sub
This one deletes line by line. Each delete action takes its time so it takes longer the more lines you delete. Also it might need to disable ScreenUpdating otherwise you see the line-by-line action.
An alternative way is to collect all the rows you want to delete with Union() and then delete them at once.
Option Explicit
Public Sub DeleteRowsWithBlankOrZeroCellsInA()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define which worksheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DeleteRange As Range
Dim iRow As Long
For iRow = LastRow To 1 Step -1 'also forward looping is possible in this case: For iRow = 1 To LastRow
If ws.Cells(iRow, "A").Value = vbNullString Or ws.Cells(iRow, "A").Value = 0 Then
If DeleteRange Is Nothing Then
Set DeleteRange = ws.Rows(iRow)
Else
Set DeleteRange = Union(DeleteRange, ws.Rows(iRow)) 'collect rows to delete
End If
End If
Next iRow
DeleteRange.Delete 'delete all at once
End Sub
This is also pretty fast because you have again only one delete action. Also it doesn't need to disable ScreenUpdating because it is one action only.
In this case it is also not necessary to loop backwards Step -1, because it just collects the rows in the loop and deletes at once (after the loop). So looping from For iRow = 1 To LastRow would also work.
There are multiple errors in your code.
First of all, your procedure should have it's scope declared.
Presumably in your case Private
You are incorrectly defining your Range() Please look at its definition
Range.Value = 0 is not the same as Range = "" or better yet IsEmpty(Range)
Looping from beginning to end when deleting individual rows will cause complications (given their indexes [indices(?)] change) - or to better word myself - it is a valid practice, but you should know what you're doing with the indexes. In your case it seems much easier to them them in the LIFO order.
Last but not least, you're unnecessarily complicating your code with certain declarations (not an error so to say, but something to be improved upon)
With all the considered, your code should look something like this:
Option Explicit
Private Sub remove_empty_rows()
Dim ws as Worksheet: Set ws = Sheets("Your Sheet Name")
Dim lr as Long
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim i as Long
For i = lr to 1 Step -1
If IsEmpty(ws.Cells(i, 1)) Then
ws.Rows(i).Delete
End If
Next i
End Sub
In general, without meaning to sound condescending, it looks like you have some learning gaps in your coding practice. I'd refer properly reading some documentation or tutorial first, before actually doing coding like this yourself.
Taking into account that A17 cell is a header, you could use AutoFilter instead of iterating over cells:
Sub FastDeleteMethod()
Dim rng As Range, rngFiltered As Range
Set rng = Range("A17:A" & Cells(Rows.Count, "A").End(xlUp).Row)
With rng
.AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:="="
On Error Resume Next
Set rngFiltered = rng.SpecialCells(xlCellTypeVisible)
If Err = 0 Then rngFiltered.EntireRow.Delete
On Error GoTo 0
End With
End Sub
I'm trying to take the output of our scheduling software for a TV station and get rid of anything for given times. Unfortunately the output of the scheduling software creates a text field for time, not a field that can be formatted to time. I haven't done any real programming in over a decade and this is frustrating me. Here's a sample of the first few rows of the sheet - every day of the month contains entries for each program from 6:00a to the next day at 5:30a.
The code I've got so far is:
Sub delete_extraneous()
Dim rng As Range
Dim j As Integer
Dim m As Integer
m = 1
j = 3
Goto ActiveSheet.Cells(j, m)
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For m = 1 To lastRow
If rng = "6:30a" Or "7:00a" Or "7:30a" Or "8:00a" Or "8:30a" Or "9:00a" Or "9:30a" Or "10:00a" Or "10:30a" Or "11:00a" Or "11:30a" Then
ActiveCell.EntireRow.Delete Shift:=xlShiftUp
End If
Next m
End Sub
Use an array of text-that-looks-like-time and match against it.
Sub delete_extraneous()
dim tms as variant, lastRow as long
tms = array("6:30a", "7:00a", "7:30a", "8:00a", "8:30a", "9:00a", "9:30a", _
"10:00a", "10:30a", "11:00a", "11:30a")
with activesheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For m = lastRow to 1 step-1
If not iserror(application.match(.Cells(m, "C").value, tms, 0)) Then
.rows(m).EntireRow.Delete Shift:=xlShiftUp
End If
Next m
.
end with
end sub
You could use Autofilter():
Sub test()
Dim hours As Variant
hours = Array("6:30a", "7:00a", "7:30a", "8:00a", "8:30a", "9:00a", "9:30a", "10:00a", "10:30a", "11:00a", "11:30a")
With Range("C1", Cells(Rows.Count, 3).End(xlUp))
.AutoFilter Field:=1, Criteria1:=hours, Operator:=xlFilterValues
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
If Not IsError(Application.Match(.Cells(1, 1).value, hours, 0)) Then .Rows(1).Delete
End With
ActiveSheet.AutoFilterMode = False
End Sub
You don't state what your specific issue is in the code, but I can tell you a few problems you have.
1) This is not valid syntax Goto ActiveSheet.Cells(j, m). There is a GoTo statement in VBA, but only use when absolutely necessary. (this case does not require it).
2) Don't rely on ActiveSheet. Instead reference the selected worksheet you desire to work with directly.
3) You never actually define rng so it's meaningless and your code will always bypass range. Using Option Explicit at the top of your modules can help avoid this issue.
4) Using active cell is also dangerous and may produce unintended consequences. In your case it will delete the same cell over and over and over again since you never activate any other cell. It's not needed.
See this code below. It also checks for row deletion and loads into a range for one delete statement later (which will be faster than deleting line by line, and doesn't require backwards looping).
Option Explicit
Sub delete_extraneous()
Dim mySheet As Worksheet
Set mySheet = Worksheets("mySheet") 'replace as needed
Dim lastRow As Long
lastRow = mySheet.Cells(mySheet.Rows.Count, 1).End(xlUp).Row
Dim m As Long
For m = 1 To lastRow
Select Case mySheet.Cells(m, 3).Value 'check each row against column C
Case Is = "6:30a", "7:00a", "7:30a", "8:00a", "8:30a", "9:00a", "9:30a", "10:00a", "10:30a", "11:00a", "11:30a"
Dim deleteRng As Range
If deleteRng Is Nothing Then
Set deleteRng = mySheet.Cells(m, 3)
Else
Set deleteRng = Union(deleteRng, mySheet.Cells(m, 3))
End If
End Select
Next
deleteRng.EntireRow.Delete
End Sub
I am attempting to use VBA to fill all blank cells in rows with the value to the left, with the exception that I only want to fill the blank cells between the first and last value in the row (not including row 1 and column A, which are identifiers).
I've struggled with getting the loop to stop once the last column with a value has been reached (as this changes with each row), rather than running all the way through the last column on the sheet.
Originally this was marked as duplicate (Autofill when there are blank values), but this does not solve the mentioned problem. This continues until the sheet ends. As seen in the picture below, the fill should stop when the last value is reached.
I am searching for a solution that will allow me to do this for an entire sheet at once, even though the data ends in different columns throughout the sheet. There are 1000+ rows, so running for each row could be quite tedious.
I've been using this code to fill the data (excluding the 1st row and column). But this is where I am not sure how to get it to stop at the last value in the row.
Sub test()
With ThisWorkbook.Sheets("Sheet1").Range("A:A")
With Range(.Cells(2, 2), .Cells(.Rows.Count, 36).End(xlUp))
With .Offset(0, 1)
.Value = .Value
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]&"""""
On Error GoTo 0
.Value = .Value
End With
End With
End With
End Sub
If my explanation was not clear, This is a sample and the output I am trying to create
Thank you all so much in advance for all your help!
You may try something like this...
Sub FillBlanks()
Dim r As Long, lr As Long, lc As Long
Dim cell As Range, FirstCell As Range, LastCell As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
For r = 3 To lr
Set FirstCell = Range(Cells(r, 1), Cells(r, lc)).Find(what:="*", after:=Cells(r, 1))
If Not FirstCell Is Nothing And FirstCell.Column > 1 Then
Set LastCell = Cells(r, Columns.Count).End(xlToLeft)
Range(FirstCell, LastCell).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]"
Range(FirstCell, LastCell).Value = Range(FirstCell, LastCell).Value
End If
Next r
End Sub
And here is yet another solution (just to give you some variety):
Option Explicit
Sub fillInTheBlanks()
Dim lngRow As Long
Dim ws As Worksheet
Dim lngColumn As Long
Dim bolStart As Boolean
Dim lngLastColumn As Long
Dim dblTempValue As Double
Dim arrSheetCopy As Variant
Set ws = ThisWorkbook.Worksheets("Sheet1")
arrSheetCopy = ws.Range(ws.Cells(3, 1), ws.Cells(ws.Cells(ws.Rows.Count, "A").End(xlUp).Row, ws.UsedRange.Columns.Count)).Value2
For lngRow = LBound(arrSheetCopy, 1) To UBound(arrSheetCopy, 1)
bolStart = False
lngLastColumn = 0
For lngColumn = LBound(arrSheetCopy, 2) To UBound(arrSheetCopy, 2)
If Not arrSheetCopy(lngRow, lngColumn) = vbEmpty Then lngLastColumn = lngColumn
Next lngColumn
For lngColumn = LBound(arrSheetCopy, 2) To lngLastColumn
If arrSheetCopy(lngRow, lngColumn) = vbEmpty And bolStart Then
arrSheetCopy(lngRow, lngColumn) = dblTempValue
Else
If Not arrSheetCopy(lngRow, lngColumn) = vbEmpty And IsNumeric(arrSheetCopy(lngRow, lngColumn)) Then
bolStart = True
dblTempValue = CDbl(arrSheetCopy(lngRow, lngColumn))
End If
End If
Next lngColumn
Next lngRow
ws.Range("A3").Resize(UBound(arrSheetCopy, 1), UBound(arrSheetCopy, 2)).Value2 = arrSheetCopy
End Sub
This one is probably the fastest solution (even though it seems a bit bulky with much more lines of code when compared to the other solutions). That's due to the fact that this solution is doing most of the work in memory and not on the sheet. The entire sheet is loaded into a variable and then the work is done on the variable before the result (the variable) is written back to the sheet. So, if you have a speed problem then you might want to consider using this solution.
Here is one possible that meets your sample data's expectations.
Sub wqewqwew()
Dim i As Long, fc As Variant, lc As Long
'necessary if you do not want to confirm numbers and blanks in any row
On Error Resume Next
With ThisWorkbook.Worksheets("Sheet6")
For i = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
If CBool(Application.Count(Rows(i))) Then
fc = Intersect(.Rows(i), .UsedRange).Offset(0, 1).SpecialCells(xlCellTypeConstants, xlNumbers).Cells(1).Column
If Not IsError(fc) Then
lc = Application.Match(9 ^ 99, .Rows(i))
On Error Resume Next
With .Range(.Cells(i, fc), .Cells(i, lc))
.SpecialCells(xlCellTypeBlanks).Cells.FormulaR1C1 = "=RC[-1]"
.Value = .Value2
End With
End If
End If
Next i
End With
End Sub
Just another solution:
The following code can help is there you need to auto-fill the previous values between 1st and last cells depending on value of 1st cell as mentioned in question Excel - VBA fill in cells between 1st and Last value
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
For i = 2 To Target.Column
If Cells(Target.Row, i) = "" Then
If Cells(Target.Row, i - 1) <> "" Then
Range(Cells(Target.Row, i), Cells(Target.Row, i)).Value = Range(Cells(Target.Row, i - 1), Cells(Target.Row, i - 1)).Value
End If
End If
Next i
End Sub
This sub is activated by clicking on any cell. Same cell marks the end of the loop i.e. to stop the loop just click the cell till which you want to fill the blank cells.
I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells.
The macro needs to recognize which cells are merged and which are not, so, I have two options:
If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.
So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what.
With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?
Code as is now:
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.count).End(xlUp).row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
rng.Select
For Each cell In rng
If cell.MergeCells Then
'Code for merged cells
Else
'Code to use for single cells
End If
Next cell
End With
ExitProgram:
Exit Sub
End Sub
Option Explicit
Sub CopyUUID()
Const UUID As Long = 31 'col AE
Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long
With ActiveSheet
kCol = -25 'col F
lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row
For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))
isM = cel.Offset(0, kCol).MergeCells
copyID = isM And Len(cel.Offset(0, kCol)) = 0
copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))
If copyID Then cel = cel.Offset(-1)
Next
End With
End Sub
Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
' Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
' rng.Select
For Each c In rng
If c.MergeCells Then
'Code for merged cells
c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
Else
'Code to use for single cells
If c.Formula = c.Offset(-1, 0).Formula Then
c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
End If
End If
Next c
End With
ExitProgram:
Exit Sub
End Sub
When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.
I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.
Hope this helps
I adopt a simple approach to this problem as illustrated through steps taken by me.
sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.
If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.
Program code is as follows:
'Without column deletion:
Sub UnMergeRanges()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
End Sub
'With coumn deletion
Sub UnMergeRangesB()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
End Sub