VBA to replace ranges of array formulae

[brettdj]

In http://vbaexpress.com/forum/showthread.php?t=6006 I had a good whinge about the worst model I'd had the misfortune to come accross, the range entered array monster

I've now had an interesting follow up question. Is it possible to write VBA to replace all the array formula in the workbook ... all 165 sheets blah blah blah

First thoughts are that it may be possible, ie using RegEx to parse all the array refs and then enter in discrete cell address, along the lines of my cell reference example in http://vbaexpress.com/kb/getarticle.php?kb_id=68 but it would be difficult

Has anyone tried or seen this done before?

Cheers

Dave

[johnske]

In http://vbaexpress.com/forum/showthread.php?t=6006 I had a good whinge about the worst model I'd had the misfortune to come accross, the range entered array monster

I've now had an interesting follow up question. Is it possible to write VBA to replace all the array formula in the workbook ... all 165 sheets blah blah blahProbably - example workbook?


First thoughts are that it may be possible, ie using RegEx to parse all the array refs and then enter in discrete cell address, along the lines of my cell reference example in http://vbaexpress.com/kb/getarticle.php?kb_id=68 but it would be difficult

Has anyone tried or seen this done before?

Cheers

Dave Not me...

[brettdj]

For example, in cells D6:F6 there is a range entered array formula
{=D1:F1+D2:F2*D4:F4}

D6 needs to become =D1+D2*D4
E6 needs to become =E1+E2*E4
F6 needs to become =F1+F2*F4

Cheers

Dave

[Ken Puls]

Curious... would it be that difficult? I can see the logic, I think...

The one thing that we can guarantee in this case is that the formulas are all relative, correct? So if we were to break down the formula you gave into it's components:
D1:F1
+
D2:F2
*
D4:F4

If, in the first component, the column letters are different on either side of the :, then results need to be run over columns. If the row numbers are different in the first component, then over rows. We'd need to work out how many columns/rows to deal with.

We should then be able to extract that the first formula is D1+D2*D4. Copy the formula we broke out into the remaining ranges to be done, based on the column/row count above.

The hardest part would be breaking it into it's components to begin with. But somehow the RegEx master could be up to it, I'm thinking. :)

Am I off base here?

[johnske]

Well, here's what I got so far for returning the cell formulas (in msgboxes here) and whether thay're an array or not Ken - go for it :) Option Explicit

Sub CellFormulaIs()
Dim Cell As Range
For Each Cell In Cells.SpecialCells(xlCellTypeFormulas)
With Cell
'not an array formula
If .HasArray = False Then
MsgBox .Address & _
" Formula is: " & .Formula
Else
'multiple result array
If IsArray(.CurrentArray) Then
MsgBox .CurrentArray.Address & _
" Formula is: " & .Formula & " (multiple array)"
'single result array
ElseIf .CurrentArray <> .Formula Then
MsgBox .CurrentArray.Address & _
" Formula is: " & .Formula & " (single array)"
End If
End If
End With
Next
End Sub

[brettdj]

Thanks guy - yep, thats what I was thinking

Find an array in column F (I left out that they should always start there - sorry) by using FIND and xlCellTypeFormulas and do a end(xltoright) to check the end array position. Then parse out the first reference in column F, and then copy the relative formula accross

The parsing may be the messy bit.

I googled this question and was somewhat surprised not to find anything

Cheers

Dave

[Ken Puls]

Okay, how's this?

I didn't put in a lot of effort for trying to meet best practices here, so just keep that in mind with the critiques. ;)

I modified the multicell array part of John's routine, added a function to check if a character was an alpha character (probably a better way to do this), and then made a function to basically stip out the second half of any range. (ie A1:A30 becomes A1)

It does seem to work for both columns and rows. I'm sure it's easily broken though, but I'll put it out there for someone else to kick around. :)

Sub NukeArrays()
Dim sFirstCell As String, sLastCell As String
Dim sFormula As String
Dim Cell As Range
For Each Cell In Cells.SpecialCells(xlCellTypeFormulas)
With Cell
'not an array formula
If .HasArray = False Then
MsgBox .Address & _
" Formula is: " & .Formula & " (No Array)"
Else
'multiple result array
If IsArray(.CurrentArray) Then
sFirstCell = Left(.CurrentArray.Address, InStr(1, .CurrentArray.Address, ":") - 1)
sLastCell = Right(.CurrentArray.Address, InStr(1, .CurrentArray.Address, ":") - 1)
sFormula = CarveUpArray(.Formula)
Range(.CurrentArray.Address).ClearContents
Range(sFirstCell).Formula = sFormula
Range(sFirstCell).Copy
Range(sFirstCell & ":" & sLastCell).PasteSpecial Paste:=xlPasteFormulas

'single result array
ElseIf .CurrentArray <> .Formula Then
MsgBox .CurrentArray.Address & _
" Formula is: " & .Formula & " (single array)"
End If
End If
End With
Next
End Sub

Function IsAlpha(sLetter As String) As Boolean
Dim AlphaArray As String
AlphaArray = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If InStr(1, AlphaArray, sLetter, vbTextCompare) > 0 Then IsAlpha = True
End Function

Function CarveUpArray(sFormula As String) As String
Dim lChars As Long
Dim bskip As Boolean

For lChars = 1 To Len(sFormula)
If bskip = True Then
If Not IsAlpha(Mid(sFormula, lChars + 1, 1)) Then
If Not IsNumeric(Mid(sFormula, lChars + 1, 1)) Then bskip = False
End If
Else
If Mid(sFormula, lChars, 1) = ":" Then
bskip = True
Else
CarveUpArray = CarveUpArray & Mid(sFormula, lChars, 1)
End If
End If
Next lChars
End Function