Extract the formulas of each cell in range - VBA

[mjgcancio]

Hello all.

I have the need to extract all the formulas from each cell in a range, and then sum them all in a single cell from that same range, and finally, merge all cells in that range.
It's something like this:



column a
after, summed and merged formula also in column a


=IF(1...)



=IF(2...)
=(IF(1…)+ (IF(2…)+(IF(3…)


=IF(3...)




In "column a" there are formulas with values and I need to copy those formulas, sum and merge them into one formula in "column a" also, using VBA.

Note: I've put the formulas into () so that each formula can work individually from the others.

Can this be done?

Thank you.

MC

[YasserKhalil]

Hello
Can you upload sample of your workbook please?

[mdmackillop]

Sub Test()
Dim r As Range
Set r = Selection 'Define as required
For i = 1 To r.Cells.Count
x = x & Replace("+(" & r(i).Formula & ")", "=", "")
Next i
r(1).Offset(r.Cells.Count + 1).Formula = "=" & x
End Sub

[p45cal]

Yes, we need a file; your previous file at http://www.vbaexpress.com/forum/showthread.php?60268-Extract-the-formulas-of-each-cell-in-range-VBA has no formulae in column A.

[mdmackillop]

Hi Pascal
That link is to this thread.:dunno

[p45cal]

Hi Pascal
That link is to this thread.:dunnoOops.
Trying again:

Yes, we need a file; your previous file at http://www.vbaexpress.com/forum/showthread.php?59698-Sum-and-merge-offset-cells-if-duplicates-are-found-in-a-certain-column-(range) has no formulae in column A.

[mjgcancio]

Hi YasserKhalil and thank you for your prompt response.

I'll try to upload a sample file tonight.

Thanks again.

[mjgcancio]

Hello p45cal :)

I'll post a new sample file tonight...I've tried to change your code so that instead of summing the values and then merge the cells, it would summed the formulas with subsequent merge of cells summed, but with no success. :banghead:

Thanks again for your help

[mjgcancio]

Hi mdmackillop and thanks for your response.

I've tried your code but didn't worked, or better I was unable to make it work. :dunno

Tonight I'll post the sample file and VBA code used (made by p45cal), along with my needs for it and also the implementatios with your code.

Thanks

[mjgcancio]

Hello all.

Sorry for not posting last night, but had some family visits. :)

Anyway, here's a sample file, along with p45cal code he wrote in the other thread and also mdmackillop code.

The point is that whenever there are duplicates in column B (or any other user-defined column), it would join/sum and merge the formulas in the correspondent rows in colums Q, U and W (also user-defined), the way I mentioned before.

p45cal's code is doing almost everything, but is summing the values instead of summing the formulas (P.S.:I'm very grateful to him, because p45cal helped me exactly with what I needed the other time) :friends:

Attached is a sample file and here's also the code posted:


Sub mergeCategoryValues()Dim lngRow As Long
Dim columnToMatch As String: columnToMatch = "B" 'the column where the duplicate values are
Dim columnsToSumAndMerge(): columnsToSumAndMerge = Array("Q", "U", "W") 'the column(s) where the formulas to sum are
Application.ScreenUpdating = False 'this saves a lot of time.
DeleteAndCopySheet 'only to work on a copy of the sheet while developing.


With ActiveSheet
lngRow = .Cells(.Rows.Count, columnToMatch).End(xlUp).Row
Set RangeToSort = .Cells(1).CurrentRegion
Set RangeToSort = Intersect(RangeToSort, RangeToSort.Offset(1))
RangeToSort.Sort key1:=RangeToSort.Cells(1, columnToMatch), Header:=xlYes
Set mydata = .Range(.Cells(3, columnToMatch), .Cells(lngRow, columnToMatch))
mydatavals = mydata.Value
Count = 1: StartBlock = 1
For i = 1 To UBound(mydatavals) - 1
If mydatavals(i, 1) = mydatavals(i + 1, 1) Then
Count = Count + 1
Else
If Count > 1 Then
SumAndMerge mydata.Cells(StartBlock, 1).Resize(Count), columnsToSumAndMerge
End If
'move on to next block:
StartBlock = StartBlock + Count: Count = 1
End If
Next i
'do the last block if there is one:
If Count > 1 Then SumAndMerge mydata.Cells(StartBlock, 1).Resize(Count), columnsToSumAndMerge
End With
Application.ScreenUpdating = True
End Sub


Sub SumAndMerge(ReferenceRange, columnsToSumAndMerge)
With ReferenceRange.Parent
For Each ColmToSumAndMerge In columnsToSumAndMerge
With Intersect(ReferenceRange.EntireRow, .Columns(ColmToSumAndMerge))
.Select
mySum = 0

'-----------------------THIS IS WHAT I NEED TO CHANGE (INSTEAD OF SUMMING THE VALUES, IT WOULD "SUM" THE FORMULAS)----------------------
mySum = Application.Sum(.Value)
.ClearContents
.Cells(1) = mySum
'---------------------------------------------------------------------------------------------------------------------------------------


.Merge
End With
Next ColmToSumAndMerge
End With
End Sub


Sub DeleteAndCopySheet()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("MJGCANCIO (2)").Delete
On Error GoTo 0
Application.DisplayAlerts = True
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Range("C3").Select
ActiveWindow.FreezePanes = True
End Sub


'------------------------------- the code mdmackillop gave -------------------------------------------------------------
Sub sumFormulas()
Dim r As Range
Set r = Selection 'Define as required
For i = 1 To r.Cells.Count
x = x & Replace("+(" & r(i).Formula & ")", "=", "")
Next i
r(1).Offset(r.Cells.Count + 1).Formula = "=" & x
End Sub




Thank you guys for all your effort, I really appreciate it.

Best regards

[mjgcancio]

Here's another sample file because the first one had no formulas in column U and W.

Sorry about that. :(

[mjgcancio]

Hello.
I've tried to implement mdmackillop's code, substituting this part:


mySum = Application.Sum(.Value)
.ClearContents
.Cells(1) = mySum

with this one:

mySum = sumFormulas


and redifining the sumFormulas() to a Function like this:


Sub mergeCategoryValues()Dim lngRow As Long
Dim columnToMatch As String: columnToMatch = "B"
Dim columnsToSumAndMerge(): columnsToSumAndMerge = Array("Q", "W")
Application.ScreenUpdating = False 'this saves a lot of time.
DeleteAndCopySheet 'only to work on a copy of the sheet while developing.


With ActiveSheet
lngRow = .Cells(.Rows.Count, columnToMatch).End(xlUp).Row
Set RangeToSort = .Cells(1).CurrentRegion
Set RangeToSort = Intersect(RangeToSort, RangeToSort.Offset(1))
RangeToSort.Sort key1:=RangeToSort.Cells(1, columnToMatch), Header:=xlYes
Set mydata = .Range(.Cells(3, columnToMatch), .Cells(lngRow, columnToMatch))
mydatavals = mydata.Value
Count = 1: StartBlock = 1
For i = 1 To UBound(mydatavals) - 1
If mydatavals(i, 1) = mydatavals(i + 1, 1) Then
Count = Count + 1
Else
If Count > 1 Then
SumAndMerge mydata.Cells(StartBlock, 1).Resize(Count), columnsToSumAndMerge
End If
'move on to next block:
StartBlock = StartBlock + Count: Count = 1
End If
Next i
'do the last block if there is one:
If Count > 1 Then SumAndMerge mydata.Cells(StartBlock, 1).Resize(Count), columnsToSumAndMerge
End With
Application.ScreenUpdating = True
End Sub


Sub SumAndMerge(ReferenceRange, columnsToSumAndMerge)
With ReferenceRange.Parent
For Each ColmToSumAndMerge In columnsToSumAndMerge
With Intersect(ReferenceRange.EntireRow, .Columns(ColmToSumAndMerge))
.Select
mySum = 0
mySum = sumFormulas
'.ClearContents
'.Cells(1) = mySum
.Merge
End With
Next ColmToSumAndMerge
End With
End Sub


Sub DeleteAndCopySheet()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("MJGCANCIO (2)").Delete
On Error GoTo 0
Application.DisplayAlerts = True
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Range("C3").Select
ActiveWindow.FreezePanes = True
End Sub


'------------------------------- the code mdmackillop gave -------------------------------------------------------------
Function sumFormulas()
Dim r As Range
Set r = Selection 'Define as required
For i = 1 To r.Cells.Count
x = x & Replace("+(" & r(i).Formula & ")", "=", "")
Next i
r(1).Offset(r.Cells.Count + 1).Formula = "=" & x
End Function




but breaks down in here:


r(1).Offset(r.Cells.Count + 1).Formula = "=" & x

Any thoughs? :help

[mjgcancio]

Well I've been doing a few tests with the Copy and Paste method and basically came to this:


Function sumFormulas() Dim r As Range
Dim cel As Range
Set r = Selection 'Define as required

For cel = 1 To r.Cells.Count
With cel
cel.Copy
cel.Offset(1).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlPasteSpecialOperationAdd, SkipBlanks:=False, Transpose:=False
End With
Next cel

End Function

I think that if it's possible with the CopynPaste method, then probably all I need to figure it out is how to copy and sum all the formulas into each of the cells of the range, so that when merged it will have all the formulas into one.

But still need your help because me knowledgement is at its limits. :doh:

What do you think?

[mdmackillop]

I couldn't work out from your post how my original code was to be implemented. Can you show on your example which formulae are to be summed and where the result should go?

Set r = Selection 'Define as required
Using this as stated is very likely to be wrong. The range needs to be set to suit your layout, as does the destination cell.

[mjgcancio]

Ok I'll do my best, starting from the beginning...hereby attached is the same sample file, but now with test values on column P, and the code divided in 3 explanations.

Please don't misinterpret me, by no means I want to be rude or ungrateful, but I just like things to be clear as water :yes and by explaining all, what we are trying to do may came in handy for someone else, right?

Here goes:

1st part of the explanation - whenever there are duplicate values/cells in column B (indicated in red in the sample file), on the same rows as the duplicates, but in this case in columns Q, U, W, the macro will analyze and when it founds those duplicates in column B...

2nd part of the explanation - ...it will:
first - select the range of cells in column Q (it can be 2 or more cells, depending on the number of duplicate cells in column B);
second - those cells I want only the formulas to be summed;
third - I need that sum to be merged on the range, like a total cell for the values in column P (so that when the values in column P changes, so does this total).

E.g.: column B duplicate value: 0660

column Q formulas to be summed (after being sorted):
1st cell of range=IF(P9<>0;IF((AND(N9="SINGULAR";P9>0));(P9/J9);(IF(N9="COLETIVA";(P9/J9);0)));0)
2nd cell of range=IF(P10<>0;IF((AND(N10="SINGULAR";P10>0));(P10/J10);(IF(N10="COLETIVA";(P10/J10);0)));0)

the result should be a merge of those cells range, into a single cell, with the following formula=(IF(P9<>0;IF((AND(N9="SINGULAR";P9>0));(P9/J9);(IF(N9="COLETIVA";(P9/J9);0)));0))+(IF(P10<>0;IF((AND(N10="SINGULAR";P10>0));(P10/J10);(IF(N10="COLETIVA";(P10/J10);0)));0))

3rd part of the explanation - it's your code (mdmackillop) that needs to sum the formulas and then merge the cellls of the range.


p45cal did a great job writing this complete macro (thank you very much), but for my purposes, I think that I need to change this line:

mySum = Application.Sum(.Value)

with this one, for calling the function (unless there is a simpler or different way):

mySum = sumFormulas

and then the real help is for the function itself, where the cell formulas need to be summed and then merged into a single cell, according to the range of cells:

'-----------------------------------------CODE OF THIRD PART OF EXPLANATION-----------------------------------------------------------
Function sumFormulas()
Dim r As Range
Set r = Selection 'Define as required
For i = 1 To r.Cells.Count
x = x & Replace("+(" & r(i).Formula & ")", "=", "")
Next i
r(1).Offset(r.Cells.Count + 1).Formula = "=" & x
End Function
'-----------------------------------------END OF THIRD PART OF EXPLANATION-----------------------------------------------------------

When running in F8 mode, the code stops at the r(1).Offset(r.Cells.Count + 1).Formula = "=" & x and I don't know how to solve that. Although I tried with different methods, like I said, my knowledge is insufficient for this. :crying:

Bellow is the full code for better visualization, also in the sample file attached.


Sub mergeCategoryValues()

'----------------------------------------------CODE OF FIRST PART OF EXPLANATION-----------------------------------------------------


Dim lngRow As Long
Dim columnToMatch As String: columnToMatch = "B" 'the column where the duplicate values are (UDF)
Dim columnsToSumAndMerge(): columnsToSumAndMerge = Array("Q", "U", "W") 'the column(s) where the formulas to sum are (UDF)

Application.ScreenUpdating = False 'this saves a lot of time.
DeleteAndCopySheet 'only to work on a copy of the sheet while developing.


'-----------------------this checks where the duplicates are in the columnToMatch column--------------------------------------------
With ActiveSheet
lngRow = .Cells(.Rows.Count, columnToMatch).End(xlUp).Row
Set RangeToSort = .Cells(1).CurrentRegion
Set RangeToSort = Intersect(RangeToSort, RangeToSort.Offset(1))
RangeToSort.Sort key1:=RangeToSort.Cells(1, columnToMatch), Header:=xlYes
Set mydata = .Range(.Cells(3, columnToMatch), .Cells(lngRow, columnToMatch))
mydatavals = mydata.Value
Count = 1: StartBlock = 1
For i = 1 To UBound(mydatavals) - 1
If mydatavals(i, 1) = mydatavals(i + 1, 1) Then
Count = Count + 1
Else
If Count > 1 Then
SumFormulasAndMerge mydata.Cells(StartBlock, 1).Resize(Count), columnsToSumAndMerge
End If
'move on to next block:
StartBlock = StartBlock + Count: Count = 1
End If
Next i
'do the last block if there is one:
If Count > 1 Then SumAndMerge mydata.Cells(StartBlock, 1).Resize(Count), columnsToSumAndMerge
End With
Application.ScreenUpdating = True
End Sub
'-----------------------------------------END OF FIRST PART OF EXPLANATION-----------------------------------------------------------


'-----------------------------------------CODE OF SECOND PART OF EXPLANATION-----------------------------------------------------------
Sub SumFormulasAndMerge(ReferenceRange, columnsToSumAndMerge)
With ReferenceRange.Parent
For Each ColmToSumAndMerge In columnsToSumAndMerge
With Intersect(ReferenceRange.EntireRow, .Columns(ColmToSumAndMerge))
.Select
mySum = 0

'THIS IS WHAT I NEED TO BE CHANGED (INSTEAD OF SUMMING THE VALUES, IT WOULD "SUM" ONLY THE FORMULAS)---------------------
' instead of mySum = Application.Sum(.Value) it would be:
mySum = sumFormulas 'the code mdmackillop gave
'-------------------------------------------------------------------------------------------------------------------------
.Merge
End With
Next ColmToSumAndMerge
End With
End Sub


'this is the macro to create a copy of the sheet while developing
Sub DeleteAndCopySheet()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("MJGCANCIO (2)").Delete
On Error GoTo 0
Application.DisplayAlerts = True
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Range("C3").Select
ActiveWindow.FreezePanes = True
End Sub
'-----------------------------------------END OF SECOND PART OF EXPLANATION-----------------------------------------------------------


'-----------------------------------------CODE OF THIRD PART OF EXPLANATION-----------------------------------------------------------
Function sumFormulas()
Dim r As Range
Set r = Selection 'Define as required
For i = 1 To r.Cells.Count
x = x & Replace("+(" & r(i).Formula & ")", "=", "")
Next i
r(1).Offset(r.Cells.Count + 1).Formula = "=" & x
End Function
'-----------------------------------------END OF THIRD PART OF EXPLANATION-----------------------------------------------------------




P.S.: there are two modules in the sample file, mergeCatValues is the one described here, and mergeCatValues1 is the one with an attempt of using a copy and paste method for solving the case, with no sucess of course. :banghead:

Thank you again for all your efforts and any questions, please just ask. :)

[mdmackillop]

For the third part, as a standalone funtion

Sub MergeFormulae()
'Identify groups
Dim R As Range
Dim Rng As Range
Set R = Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp))
Set Rng = Nothing
For Each cel In R
If cel = cel(2) Then
If Rng Is Nothing Then
Set Rng = Union(cel, cel(2))
Else
Set Rng = Union(Rng, cel(2))
End If
If cel <> cel(3) Then
Call DoMerge(Rng.Offset(, 15))
Set Rng = Nothing
End If
End If
Next
End Sub


Sub DoMerge(R As Range)
'Merge and sum
Dim x As String, y As String
With R
For i = 1 To .Cells.Count
y = R(i).Formula
x = x & "+(" & Right(y, Len(y) - 1) & ")"
Next i
.ClearContents
.Merge
.Formula = "=" & Right(x, Len(x) - 1)
.Interior.ColorIndex = 6
End With
End Sub

[mjgcancio]

:clap::clap::clap:Thanks you very much mdmackillop...and also p45cal...thank you both...here I leave the code changed for future reference, so that someone else could make use of it, or part of it.


Sub mergeIndicator()'Identify groups
Dim R As Range
Dim Rng As Range
Dim columnToMatch As String: columnToMatch = "B" 'here we define where the duplicate values are.


Application.ScreenUpdating = False 'this saves a lot of time


DeleteAndCopySheet 'only for developing or test purposes


Set R = Range(Cells(2, columnToMatch), Cells(Rows.Count, columnToMatch).End(xlUp))


'this will sort the column where duplicates are.
Set RangeToSort = Cells.CurrentRegion
Set RangeToSort = Intersect(RangeToSort, RangeToSort.Offset(1))
RangeToSort.Sort Key1:=RangeToSort.Cells(1, columnToMatch), Header:=xlYes

Set Rng = Nothing

For Each cel In R
If cel = cel(2) Then
If Rng Is Nothing Then
Set Rng = Union(cel, cel(2))
Else
Set Rng = Union(Rng, cel(2))
End If
If cel <> cel(3) Then
Call doMergeFormulas(Rng.Offset(, 15)) 'Here, we call the sub-module DoMergeFormulas or DoMergeCells,
'and in either cases, we indicate the column to
'sum and merge, through the offset column number.
Set Rng = Nothing
End If
End If
Next


Application.ScreenUpdating = True


End Sub




Sub doMergeFormulas(R As Range)
'Merge and sum Formulas


Dim x As String, y As String


With R
For i = 1 To .Cells.Count
y = R(i).Formula
x = x & "+(" & Right(y, Len(y) - 1) & ")" 'ATENTION: if we are summing number formulas, we use the "+" sign in the line of code
'if we are summing text formulas, we use the "&" sign in the line of code
'this line of code is very adaptable
Next i
.ClearContents
.Merge
.Formula = "=" & Right(x, Len(x) - 1) 'this line of code is very adaptable
.Interior.ColorIndex = 6 'helpfull for visualyzing
End With


End Sub


Sub doMergeCells(R As Range)
'Merge and sum only the values, or only the cells, if blank cells


Dim x As String, y As String


Application.DisplayAlerts = False 'for not to display the merge alerts


With R
.Select
.Value = Application.Sum(.Value)

For i = 1 To .Cells.Count

If R(i).Value = 0 Then
.ClearContents
Else
End If

Next i

.Merge
.Interior.ColorIndex = 6 'helpfull for visualyzing
End With

Application.DisplayAlerts = True


End Sub


Sub DeleteAndCopySheet()
'this is the macro to create a copy of the sheet while developing or testing
Application.DisplayAlerts = False
On Error Resume Next
Sheets("MJGCANCIO (2)").Delete
On Error GoTo 0
Application.DisplayAlerts = True
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Range("C3").Select
ActiveWindow.FreezePanes = False
End Sub




Sorry for the bad indent. :)

Best wishes and God bless you. : pray2:
MC

[mdmackillop]

Glad it worked out.

If you may be working with Text/Formulas I suggest you test for the initial "=" and create a modified "join" using "&" as you stated