I have looked through the other posts about this and have tried adapted the strategies that were recommend by using Set ActiveWorkbook and Set Active Worksheet and I still get the same error. I hope another set of eyes can help out as I am still very new to VBA and I am not all that comfortable with it yet.
Basically the idea is to copy the cells from column f to column j as values as long as the cells of F do not match the cells of J. I get the row count of column E and use that as my count in the for loop.
Code is here:
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim n As Integer
Dim i As Integer
n = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
i = n
For Counter = 1 To n
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
i = i + 1
Next Counter
End Sub
Thanks for the help
Also Edit:
Link to Excel Sheet that has a before page, after first transaction sheet ,and a after second transaction sheet: https://www.dropbox.com/s/n2mn0zyrtoscjin/Rewards.xlsm
CHange this:
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
To this:
Set curCell = Sheets("Calculate").Range("F2:F" & i)
If curCell <> Sheets("Calculate").Range("$J" & i) Then
Sheets("Calculate").Range("$J:$J" &i).Value = curCell.Value
End If
May need to do some more teaking as I notice you're working with SpecialCells which essentially filters the range, so iterating For i = 1 to n... probably does not work. Maybe something like:
Dim rngCalc as Range
Set rngCalc = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants)
For each curCell in rngCalc.Cells
If curCell <> curCell.Offset(0, 4) Then
curCell.Offset(0, 4).Value = curCell.Value
End If
Next
EDIT: this sub will calculate the points for the last transaction (identified as the furthest-right column containing transactions) and write them down in column C.
Option Explicit
Sub UpdateCurrentPurchase()
Dim CalcSheet As Worksheet
Dim LastTransRange As Range, TargetRange As Range
Dim LastTransCol As Long, LastTransRow As Long
Dim PurchaseArray() As Variant
Dim Points As Long, Index As Long
'set references up-front
Set CalcSheet = ThisWorkbook.Worksheets("Calculate")
With CalcSheet
LastTransCol = .Cells(2, .Columns.Count).End(xlToLeft).Column '<~ find the last column
LastTransRow = .Cells(.Rows.Count, LastTransCol).End(xlUp).Row
Set LastTransRange = .Range(.Cells(2, LastTransCol), .Cells(LastTransRow, LastTransCol))
Set TargetRange = .Range(.Cells(2, 6), .Cells(LastTransRow, 6)) '<~ column F is the Current Purchase Col
LastTransRange.Copy Destination:=TargetRange '<~ copy last transactions to Current Purchase Col
End With
'pull purchases into a variant array
PurchaseArray = TargetRange
'calculate points
For Index = 1 To LastTransRow
Points = Int(PurchaseArray(Index, 1) / 10) '<~ calculate points
CalcSheet.Cells(Index + 1, 3) = Points '<~ write out the points amount in col C
Next Index
End Sub
ORIGINAL RESPONSE: I think the below will get you where you're going. That being said, it seems like simply overwriting column J with column F (as values) might be the fastest way to an acceptable answer, so if that's the case we can re-work this code to be much quicker using Range objects.
Option Explicit
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim LastRow As Long, Counter As Long
Dim cSheet As Worksheet '<~ add a worksheet reference to save some typing
'set references up front
Set cSheet = ThisWorkbook.Worksheets("Calculate")
With cSheet
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row '<~ set loop boundary
'loop that compares the value in column 6 (F) to the value in
'column 10 (J) and writes the value from F to J if they are not equal
For Counter = 1 To LastRow
If .Cells(Counter, 6).Value <> .Cells(Counter, 10).Value Then
.Cells(Counter, 10) = .Cells(Counter, 6)
End If
Next Counter
End With
End Sub
Related
I would like to write a UDF (user defined function, aka. macro) that will be used in each of the green cells. In this function/macro in want to get the length of the longest string in the framed cells next to my current group of green cells. In order to do this in the macro I need to determine a range that represents all of the framed cells next to the current cell. (This calculation should result the same range object for each cell in one green group but a different one from group to group.) How would you get this Range?
My first try was this:
Range(Application.Caller.Offset(0, -1).End(xlUp),_
Application.Caller.Offset(0, -1).End(xlDown))
But this
doesn't work
would give false range if the caller cell is the uppermost or lowermost cell of a group.
I would need something like ActiveCell.Offset(0, -1).CurrentRegion, but in the vertical direction only.
Try this:
Function findlongest()
Dim fullcolumn() As Variant
Dim lastrow As Long
Dim i As Long, j As Long, k As Long
Dim tmax As Long
tmax = 0
With Application.Caller
lastrow = .Parent.Cells(.Parent.Rows.Count, .Column - 1).End(xlUp).Row
fullcolumn = .Parent.Range(.Parent.Cells(1, .Column - 1), .Parent.Cells(lastrow, .Column - 1)).Value
For j = .Row To 1 Step -1
If fullcolumn(j, 1) = "" Then
j = j + 1
Exit For
ElseIf j = 1 Then
Exit For
End If
Next j
For i = .Row To UBound(fullcolumn, 1)
If fullcolumn(i, 1) = "" Then
i = i - 1
Exit For
ElseIf i = UBound(fullcolumn, 1) Then
Exit For
End If
Next i
'to get the range
Dim rng As Range
Set rng = .Parent.Range(.Parent.Cells(j, .Column - 1), Parent.Cells(i, .Column - 1))
'then do what you want with rng
'but since you already have the values in an array use that instead.
'It is quciker to iterate and array than the range.
For k = j To i
If Len(fullcolumn(k, 1)) > tmax Then tmax = Len(fullcolumn(k, 1))
Next k
findlongest = tmax
End With
End Function
Are you after something like the code below:
Option Explicit
Sub GetLeftRange()
Dim myRng As Range
Set myRng = ActiveCell.Offset(, -1).CurrentRegion
Debug.Print myRng.Address
End Sub
Note: ActiveCell is one of the cells you marked as green.
This is an example of setting each range using Area.
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range
Dim rngA As Range, rng As Range
Set Ws = ActiveSheet
With Ws
Set rngDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
Set rngA = rngDB.SpecialCells(xlCellTypeConstants, xlTextValues)
For Each rng In rngA.Areas
rng.Offset(, 1).Select '<~~ select is not required but is intended to be visualized
Next rng
End With
End Sub
I'm not sure where I'm going wrong. I'm trying to compare values within a column ("B") to a cell referenced to ("A1"). If the values in Column "B" equal "A1" I want it to count up. When it gets to the end of Column "B" I'm trying to get it to loop back and compare values in column "B" with "A2", etc. For example:
So Far I've written two different codes one with a nested do while loop and a nested do while if loop but i cant get them to loop through the whole column
Sub CountDb()
Dim i As Long
Dim iRow As Long
Dim initial As Long
i = 1
iRow = 1
initial = 1
Do While Cells(iRow, "A").Value <> "" 'initial loop, whilst there are values in cell "A" continue the loop
Do While Cells(i, "B").Value = Cells(iRow, "A").Value 'nested while loop, comparing the first B1 and cell A1.
If True Then Cells(i, "C") = initial 'if they A1 and B1 are equal, print 1 in column C
initial = initial + 1 'and move on comparing A1 with B2
If False Then
i = i + 1 'if not satisfied, move on to cell B2 etc.
Loop
iRow = iRow + 1 'when you get to the end of column B, start again and compare values with A2 and B
Loop
End Sub
Sub CountDb()
Dim i As Long
Dim iRow As Long
Dim initial As Long
'same comments as above, just different methodology
i = 1
iRow = 1
initial = 1
Do While Cells(iRow, "A").Value <> ""
If Cells(i, "B").Value = Cells(iRow, "A").Value Then
Cells(i, "C") = initial
Else
initial = initial + 1
i = i + 1
End If
iRow = iRow + 1
Loop
End Sub
Any help would be appreciated. Thanks!
*EDIT - fixed up column references
**EDIT - applied comments to code
Try this instead:
Option Explicit
Sub test()
Dim sht As Worksheet
Dim lastrow As Long, i as integer, j as integer, initial as integer
Set sht = Workbooks("Book1").Worksheets("Sheet1") 'Don't forget to change this
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
initial = 1
lastrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For j = 1 To lastrow
If Workbooks("Book1").Worksheets("Sheet1").Range("A" & i).Value = Workbooks("Book1").Worksheets("Sheet1").Range("B" & j).Value Then
Workbooks("Book1").Worksheets("Sheet1").Range("C" & j).Value = initial
initial = initial + 1
End If
Next j
Next i
End Sub
I prefer using For loops as opposed to Whiles, just because I can see the ranges being looped through more easily. Here we use nested For loops, the first to loop through column A, the second to loop through column B. If our value in column A equals our value in column B, we place the initial number in column C using our variable from the nested loop.
Notice how to make this work, we re-initialize our lastrow variable to make the ranges for our loops.
It is useful to use countif.
Sub test()
Dim rngOrg As Range, rngDB As Range
Dim Wf As WorksheetFunction
Dim vR() As Variant
Dim i As Long, n As Long
Set Wf = WorksheetFunction
Set rngOrg = Range("a1", Range("a" & Rows.Count).End(xlUp))
Set rngDB = Range("b1", Range("b" & Rows.Count).End(xlUp))
n = rngDB.Rows.Count
ReDim vR(1 To n, 1 To 1)
For Each Rng In rngDB
i = i + 1
If Wf.CountIf(rngOrg, Rng) Then
vR(i, 1) = Wf.CountIf(Range("b1", Rng), Rng)
End If
Next Rng
Range("c1").Resize(n) = vR
End Sub
Here is another method, this time using Find. This is probably quicker than the looping method since it leverages the in-built find function to skip to the next match.
I've commented the code below for clarity, but basically we loop through values in column A (using a For loop because they're less prone to disguised infinite looping than While) and look for them in column B.
Note: This looks a bit longer, but that's mainly because (a) I've added lots of comments and (b) I've used a With statement to ensure the ranges are fully qualified.
Sub countdb()
Dim c As Range, fnd As Range, listrng As Range, cnt As Long, addr As String
' Use with so that our ranges are fully qualified
With ThisWorkbook.Sheets("Sheet1")
' Define the range to look up in (column B in this case)
Set listrng = .Range("B1", .Range("B1").End(xlDown))
' Loop over values in the index range (column
For Each c In .Range("A1", .Range("A1").End(xlDown))
cnt = 0
' Try and find the c value
Set fnd = listrng.Find(what:=c.Value, lookat:=xlWhole, LookIn:=xlValues, after:=listrng.Cells(listrng.Cells.Count))
If Not fnd Is Nothing Then
' Store the address of the first find so we can stop when we find it again!
addr = fnd.Address
' Loop over all other matches in the range. By using a "Do ... Loop While"
' style loop, we ensure that the loop is run at least once!
Do
' Increase count and assign value to next column
cnt = cnt + 1
fnd.Offset(0, 1).Value = cnt
' Find next match after current
Set fnd = listrng.Find(what:=c.Value, lookat:=xlWhole, LookIn:=xlValues, after:=fnd)
Loop While fnd.Address <> addr
End If
Next c
End With
End Sub
The trick is in making the declarations transparent. After that the programming is very easy.
Sub CountMatches()
Dim Rng As Range ' "count" range (= column "B")
Dim Itm As String ' item from the "items' column (= "A")
Dim Rla As Long, Rlb As Long ' last row in columns A and B
Dim Ra As Long, Rb As Long ' row counters
Dim Counter As Long ' count matches
With ActiveSheet
' look for the last used rows
Rla = .Cells(.Rows.Count, "A").End(xlUp).Row
Rlb = .Cells(.Rows.Count, "B").End(xlUp).Row
' start looking for matches from row 2
Set Rng = .Range(.Cells(2, "B"), .Cells(Rlb, "B"))
' start looping in row 2
For Ra = 2 To Rla
Itm = .Cells(Ra, "A").Value
If Len(Trim(Itm)) Then ' skip if blank
' start comparing from row 2
For Rb = 2 To Rlb
' compare not case sensitive
If StrComp(.Cells(Rb, "B").Value, Itm, vbTextCompare) = 0 Then
Counter = Counter + 1
End If
Next Rb
.Cells(Ra, "C").Value = Counter
Counter = 0
End If
Next Ra
End With
End Sub
Now the question is whether the transparency that workred for me appears transparent to you. I hope it does. :-)
This should be significantly faster.
Sub CountMatches_2()
Dim Rng As Range ' "count" range (= column "B")
Dim Itm As String ' item from the "items' column (= "A")
Dim Rla As Long, Rlb As Long ' last row in columns A and B
Dim Ra As Long, Rb As Long ' row counters
With ActiveSheet
' look for the last used rows
Rla = .Cells(.Rows.Count, "A").End(xlUp).Row
Rlb = .Cells(.Rows.Count, "B").End(xlUp).Row
' start looking for matches from row 2
Set Rng = .Range(.Cells(2, "B"), .Cells(Rlb, "B"))
' start looping in row 2
For Ra = 2 To Rla
Itm = .Cells(Ra, "A").Value
If Len(Trim(Itm)) Then ' skip if blank
.Cells(Ra, "C").Value = Application.CountIf(Rng, Itm)
End If
Next Ra
End With
End Sub
This code presumes that each item in column A is unique. If it is not duplicates will be created which, however, it would be easy to eliminate either before or after they are created.
I am really stuck on a code for this form.
I want to create a command button that will allow the user to simplify the report and combine all like items and remove the duplicates. This will be used a Purchase request. I've attached a photo of the form here ->
Form
I need the button to find duplicates in column C and sum the totals from column F and then remove duplicates leaving the original behind with a grand total in the QTY menu. Is that possible and still keep it on the same sheet or would it be better to have it duplicate to a new sheet?
If the key is column C, this macro should do what you want, attach it to the button. To make it changeable easily for the key column, I defined the key as a constant and set it to 3 for now (col C):
Sub ProcessForm()
Dim wholeRange As Range, i As Long, ar
Const key As Long = 3 ' <-- column C is key. Set to 1 if col A
With Worksheets("Order")
Set wholeRange = .Range("A5:G" & .Cells(.Rows.Count, key).End(xlUp).row)
End With
With wholeRange
ar = .Columns(key).value
For i = 1 To UBound(ar)
ar(i, 1) = WorksheetFunction.SumIfs(.Columns(6), .Columns(key), ar(i, 1))
Next
.Columns(6).value = ar
.RemoveDuplicates key
End With
End Sub
Sub main()
Dim cell As Range
With Worksheets("Order")
With .Range("C5", .Cells(.Rows.Count, 3).End(xlUp))
For Each cell in .Cells
cell.Offset(,3).Value = WorksheetFunction.SumIf(.Cells, cell, .Offset(,3))
Next
.Offset(, -2).Resize(, 7).RemoveDuplicates Columns:=Array(3), Header:=xlNo
End With
End With
End Sub
Without seeing your code its difficult to say what your stuck on but here is quick example on How to search duplicates and sum the value
I'm using WorksheetFunction.Match Method (Excel)
Option Explicit
Sub Example()
' // Declare Variables
Dim DupRow As Variant
Dim i As Long
Dim LastRow As Long
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Sheets("Sheet1")
With Sht
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
For i = LastRow To 2 Step -1
' // Columns 3 (C) DupRow
DupRow = Application.Match(Cells(i, 3).Value, Range(Cells(1, 3), Cells(i - 1, 3)), 0)
If Not IsError(DupRow) Then
' // Columns 6 (F) sum Match
Cells(i, 6).Value = Cells(i, 6).Value + Cells(DupRow, 6).Value
Rows(DupRow).Delete ' Delete DupRow
End If
Next i
End With
End Sub
I am trying to run a macro on 3 different ranges, one after another. Once the range is selected, the code works just fine (where variables F and L are defined). I would like to set r1-r3 as Ranges I need and then use a string variable to concatenate the range numbers together. This code works, but doesn't provide the starting and ending row number in the range selected. This is vital because it tells the "TableCalc" macro when to start and stop the code. I would then like to move on to the next range. Thanks for your help.
Sub TestRangeBC()
WS.Select
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rngx As String
Dim num As Integer
Dim rng As Range
Set r1 = WS.Range("ONE")
Set r2 = WS.Range("TWO")
Set r3 = WS.Range("THREE")
For num = 1 To 3
rngx = "r" & num
Set rng = Range(rngx)
Dim F As Integer
Dim L As Integer
F = rng.Row + 1
L = rng.Row + rng.Rows.Count - 2
Cells(F, 8).Select
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
'INSERT SITUATIONAL MACRO
Call TableCalc
WS.Select
ActiveCell.Offset(1, 0).Select
Loop
Next num
End Sub
This is not the answer (as part of your code and what you are trying to achieve is unclear yet), but it is a "cleaner" and more efficient way to code what you have in your original post.
Option Explicit
Dim WS As Worksheet
Your original Sub shorten:
Sub TestRangeBC()
' chanhe WS to your Sheet name
Set WS = Sheets("Sheet1")
Call ActiveRange("ONE")
Call ActiveRange("TWO")
Call ActiveRange("THREE")
End Sub
This Sub gets the Name of the Named Range (you set in your workbook) as a String, and sets the Range accordingly.
Sub ActiveRange(RangeName As String)
Dim Rng As Range
Dim F As Integer
Dim L As Integer
Dim lRow As Long
With WS
Set Rng = .Range(RangeName)
' just for debug purpose >> to ensure the right Range was passed and set
Debug.Print Rng.Address
F = Rng.Row + 1
L = Rng.Row + Rng.Rows.Count - 2
lRow = F
' what you are trying to achieve in this loop is beyond me
Do While .Cells(F, 8) <> "" And .Cells(lRow, 8).Row <= L
Debug.Print .Cells(lRow, 8).Address
'INSERT SITUATIONAL MACRO
' Call TableCalc
' not sure you need to select WS sheet again
WS.Select
lRow = lRow + 1
Loop
End With
End Sub
What are you trying to test in the loop below, what are the criteria of staying in the loop ?
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
it's really hard to tell what you may want to do
but may be what follows can help you clarifying and (hopefully) doing it!
first off, you can't "combine" variable names
So I'd go with an array of named ranges names (i.e. String array) to be filled by means of a specific sub:
Function GetRanges() As String()
Dim ranges(1 To 3) As String
ranges(1) = "ONE"
ranges(2) = "TWO"
ranges(3) = "THREE"
GetRanges = ranges
End Function
so that you can clean up your "main" sub code and keep only more relevant code there:
Sub TestRangeBC()
Dim r As Variant
Dim ws As Worksheet
Set ws = Worksheets("Ranges") '<--| change "Ranges" to your actual worksheet name
For Each r In GetRanges() '<--| loop through all ranges names
DoIt ws, CStr(r) '<--| call the range name processing routine passing worksheet and its named range name
Next r
End Sub
the "main" sub loops through the named ranges array directly collected from GetRanges() and calls DoIt() to actually process the current one:
Sub DoIt(ws As Worksheet, rangeName As String)
Dim cell As Range
Dim iRow As Long
With ws.Range(rangeName) '<--| reference the passed name passed worksheet named range
For iRow = .Rows(2).Row To .Rows(.Rows.Count - 2).Row '<--| loop through its "inner" rows (i.e. off 1st and last rows)
Set cell = ws.Cells(iRow, 8) '<--| get current row corresponding cell in column "F"
If cell.value = "" Then Exit For '<--| exit at first blank column "F" corresponding cell
TableCalc cell '<-- call TableCalc passing the 'valid' cell as its parameter
Next iRow
End With
End Sub
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