optimise code -> subroutine to function (paramarray??!)

tozjerimiah

New Member
Joined
Nov 1, 2011
Messages
3
Currently I do this:

Code:

Code:
    For CurrentTableRow = WallTableBeginsRow To WallTableBeginsRow + NumberOfWalls
        If (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Bwk") And (Cells(CurrentTableRow, FloorCol).Value = "GF") Then
            GFBWKArrayNumber = GFBWKArrayNumber + 1
            ReDim Preserve GFBWK(1 To GFBWKArrayNumber)
            GFBWK(GFBWKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * " & (Cells(CurrentTableRow, HeightCol).Value)
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Blk") And (Cells(CurrentTableRow, FloorCol).Value = "GF") Then
            GFBLKArrayNumber = GFBLKArrayNumber + 1
            ReDim Preserve GFBLK(1 To GFBLKArrayNumber)
            GFBLK(GFBLKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * " & (Cells(CurrentTableRow, HeightCol).Value)
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Bwk") And (Cells(CurrentTableRow, FloorCol).Value = "FF") Then
            FFBWKArrayNumber = FFBWKArrayNumber + 1
            ReDim Preserve FFBWK(1 To FFBWKArrayNumber)
            FFBWK(FFBWKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * " & (Cells(CurrentTableRow, HeightCol).Value)
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Blk") And (Cells(CurrentTableRow, FloorCol).Value = "FF") Then
            FFBLKArrayNumber = FFBLKArrayNumber + 1
            ReDim Preserve FFBLK(1 To FFBLKArrayNumber)
            FFBLK(FFBLKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * " & (Cells(CurrentTableRow, HeightCol).Value)
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Bwk") And (Cells(CurrentTableRow, FloorCol).Value = "TOP") Then
            TOPBWKArrayNumber = TOPBWKArrayNumber + 1
            ReDim Preserve TOPBWK(1 To TOPBWKArrayNumber)
            TOPBWK(TOPBWKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * (" & (Cells(CurrentTableRow, HeightCol).Value) & " /2)"
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Blk") And (Cells(CurrentTableRow, FloorCol).Value = "TOP") Then
            TOPBLKArrayNumber = TOPBLKArrayNumber + 1
            ReDim Preserve TOPBLK(1 To TOPBLKArrayNumber)
            TOPBLK(TOPBLKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * (" & (Cells(CurrentTableRow, HeightCol).Value) & " /2)"
        Else: End If
    Next CurrentTableRow


I want to optimise this by turning it into a function; basically it extracts data from a table based on parameters...

You will notice that each of the above conditions only use 2 parameters, however I would like to be able to pass the function any number... so what I'm thinking is basically:

allBrick = functionname(table (search_one, search_two), (search_one, search_three, search_four))

I guess that the function would return an array...

I hope that this makes sense... knowing that what I am wanting to do is possible would be a great start!!

Thanks
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

dragontooth

New Member
Joined
Mar 3, 2008
Messages
29
I have no way of testing this so I will have to depend on you :)

I made a HUGE assumtion, that is that the cells object will still be available otherwise I will have to rework it some.

Below is your code "modified" to use the sub.
Code:
For CurrentTableRow = WallTableBeginsRow To WallTableBeginsRow + NumberOfWalls
        If (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Bwk") And (Cells(CurrentTableRow, FloorCol).Value = "GF") Then
            AddArrayElement GFBWKArrayNumber, GFBWK, CurrentTableRow, LengthCol, HeightCol
'            GFBWKArrayNumber = GFBWKArrayNumber + 1
'            ReDim Preserve GFBWK(1 To GFBWKArrayNumber)
'            GFBWK(GFBWKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * " & (Cells(CurrentTableRow, HeightCol).Value)
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Blk") And (Cells(CurrentTableRow, FloorCol).Value = "GF") Then
            AddArrayElement GFBLKArrayNumber, GFBLK, CurrentTableRow, LengthCol, HeightCol
'            GFBLKArrayNumber = GFBLKArrayNumber + 1
'            ReDim Preserve GFBLK(1 To GFBLKArrayNumber)
'            GFBLK(GFBLKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * " & (Cells(CurrentTableRow, HeightCol).Value)
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Bwk") And (Cells(CurrentTableRow, FloorCol).Value = "FF") Then
            AddArrayElement FFBWKArrayNumber, FFBWK, CurrentTableRow, LengthCol, HeightCol
'            FFBWKArrayNumber = FFBWKArrayNumber + 1
'            ReDim Preserve FFBWK(1 To FFBWKArrayNumber)
'            FFBWK(FFBWKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * " & (Cells(CurrentTableRow, HeightCol).Value)
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Blk") And (Cells(CurrentTableRow, FloorCol).Value = "FF") Then
            AddArrayElement FFBLKArrayNumber, FFBLK, CurrentTableRow, LengthCol, HeightCol
'            FFBLKArrayNumber = FFBLKArrayNumber + 1
'            ReDim Preserve FFBLK(1 To FFBLKArrayNumber)
'            FFBLK(FFBLKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * " & (Cells(CurrentTableRow, HeightCol).Value)
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Bwk") And (Cells(CurrentTableRow, FloorCol).Value = "TOP") Then
            AddArrayElement TOPBWKArrayNumber, TOPBWK, CurrentTableRow, LengthCol, HeightCol, " /2)"
'            TOPBWKArrayNumber = TOPBWKArrayNumber + 1
'            ReDim Preserve TOPBWK(1 To TOPBWKArrayNumber)
'            TOPBWK(TOPBWKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * (" & (Cells(CurrentTableRow, HeightCol).Value) & " /2)"
        ElseIf _
        (Cells(CurrentTableRow, BwkBlkStudCol).Value = "Blk") And (Cells(CurrentTableRow, FloorCol).Value = "TOP") Then
            AddArrayElement TOPBLKArrayNumber, TOPBLK, CurrentTableRow, LengthCol, HeightCol, " /2)"
'            TOPBLKArrayNumber = TOPBLKArrayNumber + 1
'            ReDim Preserve TOPBLK(1 To TOPBLKArrayNumber)
'            TOPBLK(TOPBLKArrayNumber) = (Cells(CurrentTableRow, LengthCol).Value) & " * (" & (Cells(CurrentTableRow, HeightCol).Value) & " /2)"
        Else: End If
    Next CurrentTableRow
 
' Here is the sub you asked for
 
Sub AddArrayElement(Cnt As Long, arrArray(), CTR As Long, LC As Long, HC As Long, Optional DB2 As String)
    Cnt = Cnt + 1
    ReDim Preserve arrArray(1 To Cnt)
    arrArray(Cnt) = (Cells(CTRow, LC).Value) & " * (" & (Cells(CTR, HC).Value) & IIf(DB2 <> "", " /2)", ")")
End Sub
 

tozjerimiah

New Member
Joined
Nov 1, 2011
Messages
3
Hi there, thanks for your help... I have replaced my old code with yours, obviously putting the new sub in a separate subroutine. However when I run it, I get a ByRef Arguement Type Mismatch compile error... I have uploaded the spreadsheet, in the hope that you will have a look.
Thanks
 

dragontooth

New Member
Joined
Mar 3, 2008
Messages
29
I had a typo, the type declarations I had were not what you had so this is what I got to work.
Code:
Sub AddArrayElement(Cnt, arrArray() As String, CTR, LC, HC, Optional DB2 As String)
    Cnt = Cnt + 1
    ReDim Preserve arrArray(1 To Cnt)
    arrArray(Cnt) = (Cells(CTR, LC).Value) & " * (" & (Cells(CTR, HC).Value) & IIf(DB2 <> "", " /2)", ")")
End Sub
 

Biz

Well-known Member
Joined
May 18, 2009
Messages
1,707
Office Version
  1. 2010
Platform
  1. Windows
Too many elseif.

Try using Case Statements
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,328
Office Version
  1. 365
Platform
  1. Windows
What is this code meant to do?

If you want to use a ParamArray I think we'd need to know that so we can see what parameters are actually involved.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,836
Messages
5,766,720
Members
425,373
Latest member
ndiejennrrd

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top