Speed up Code to value all sheets

[howard]

I have code below to copy and paste values. I then have one Macro combining several macro like the one below to range value the ranges on all sheets (+- 25 sheets)

It takes +-5 mins to rn and would lioke to know if the code can be amended to speed up the process

 Sub Range_ValPRofits_BRAut()

 Dim arr As Variant
    Dim n   As Variant

    Set arr = Range("NP1_BrAu, NP2_BRAUT, NP3_AUT, NP4_AUT, NP5_AUT")

   With Sheets("Br1")
                For Each n In arr
            If .Cells(5, n.Column).Value <> "Finalised" Then
                n.Offset(1).Value = n.Value
            End If
        Next n
    End With
    Application.CutCopyMode = False
Range("a1").Select


   
End Sub

 

[offthelip]

The reason your code is slow is because you are looping through each cell in your range this is always very slow. I notice that you defined Arr as a variant however the statement:

Set arr = Range("NP1_BrAu, NP2_BRAUT, NP3_AUT, NP4_AUT, NP5_AUT")

means it is actually a range.
To speed this up you need to load the range into a variant array. Also your loop would need to change because you can't just loop through every item in a variant array in a single loop unlessthe varaint aray is a one dimensional array. So how you rewrite the code depends on what shape you named ranges are. If the range are two dimensional then you need a double loop. Here are three examples of what you need to do.

Sub test()
arr = Range("A1:A24") ' loop through a range of rows
For i = 1 To UBound(arr, 1)
 tt = arr(i, 1) ' this loops through the values
Next i
''
arr = Range("A1:C1") ' loop through a range of Column
For i = 1 To UBound(arr, 2)   ' note this change
 tt = arr(1, i) ' this loops through the values and this change
Next i

arr = Range("A1:C24") ' loop through a range of rows Column
For i = 1 To UBound(arr, 1)   ' note this change this loops through the rows
 For j = 1 To UBound(arr, 2)   ' this loops through the column
 tt = arr(i, j) ' this loops through the values and this change
 Next j
Next i


End Sub

Note also that you can't write out to the worksheet using the offset function when you are using varaint arrays once agains you need to know where you range are so that you can convert the indices into the variant array into a cell address

 

[HaHoBe]

Hi howard,

this is what I figured out (to me quite a lot of information is missing here):

Sub Range_ValPRofits_BRAut_Guess()

Dim rngSet    As Range
Dim rngCell   As Range

With Sheets("Br1")
  Set rngSet = Intersect(.Range("NP1_BrAu, NP2_BRAUT, NP3_AUT, NP4_AUT, NP5_AUT"), .Rows(5))
  For Each rngCell In rngSet
    If rngCell.Value <> "Finalised" Then
      rngCell.Offset(1).Value = rngCell.Value
    End If
  Next rngCell
End With
Application.CutCopyMode = False
Range("a1").Select
Set rngCell = Nothing

End Sub

Ciao,
Holger

 

[howard]

Hi Holdger


When running yoir code, I get Object required and the code below is highlighted

 For Each rngCell In rngSet

 

[howard]

The reason your code is slow is because you are looping through each cell in your range this is always very slow. I notice that you defined Arr as a variant however the statement:

Set arr = Range("NP1_BrAu, NP2_BRAUT, NP3_AUT, NP4_AUT, NP5_AUT")

means it is actually a range.
To speed this up you need to load the range into a variant array. Also your loop would need to change because you can't just loop through every item in a variant array in a single loop unlessthe varaint aray is a one dimensional array. So how you rewrite the code depends on what shape you named ranges are. If the range are two dimensional then you need a double loop. Here are three examples of what you need to do.

Sub test()
arr = Range("A1:A24") ' loop through a range of rows
For i = 1 To UBound(arr, 1)
 tt = arr(i, 1) ' this loops through the values
Next i
''
arr = Range("A1:C1") ' loop through a range of Column
For i = 1 To UBound(arr, 2)   ' note this change
 tt = arr(1, i) ' this loops through the values and this change
Next i

arr = Range("A1:C24") ' loop through a range of rows Column
For i = 1 To UBound(arr, 1)   ' note this change this loops through the rows
 For j = 1 To UBound(arr, 2)   ' this loops through the column
 tt = arr(i, j) ' this loops through the values and this change
 Next j
Next i


End Sub

Note also that you can't write out to the worksheet using the offset function when you are using varaint arrays once agains you need to know where you range are so that you can convert the indices into the variant array into a cell address

Thanks for your input offthelip

 

[howard]

Hi Holger

I have attached samle files to make it easier to follow

Branch Profits.xlsx

Shared with Dropbox

www.dropbox.com

Profits.xlsx

Shared with Dropbox

www.dropbox.com

 

[Alex Blakenburg]

In Branch Profits all your range names are 2 rows but it sounds to me like you only want to look at the 1st row in each range and if Row 5 in the same column <> Finalised then copy the "value" of the formula down to the next row, is that correct ?
(The sample sheet is missing the range name NP4_AUT, I assume that is rows 19:20.)

I assume the Profits workbook is just there so that the formulas produce a value and that we can ignore it for the purposes of the macro.

 

[howard]

Hi Alex

Thanks for he reply. tyour assuptions are correct .I want to look at the first row in ech range andnd if Row 5 in the same column <> Finalised , then the to copy the 1st row in each range to the nextrow

 

[Alex Blakenburg]

I am sure one of the others can do it in far less code than I have done it in but give this a try:
(The convoluted heading line is mainly because I didn't want to hard code the column range since you were relying on range names for everything else)

 Sub Range_ValPRofits_BRAut()

    Dim arr As Variant
    Dim strArr As Variant
    Dim rngHdg As Range, arrHdg As Variant
    Dim arrData As Variant
    Dim n   As Variant

    With Sheets("Br1")
        strArr = Split("NP1_BrAu, NP2_BRAUT, NP3_AUT, NP4_AUT, NP5_AUT", ",")
        Set rngHdg = .Cells(5, .Range(strArr(0)).Cells(1).Column).Resize(1, .Range(strArr(0)).Columns.Count)
        arrHdg = rngHdg.Value2
  
        Dim i As Long, jcol As Long
       
        For i = 0 To UBound(strArr)
            arrData = .Range(strArr(i))
            For jcol = 1 To UBound(arrData, 2)
                If arrHdg(1, jcol) <> "Finalised" Then
                    arrData(2, jcol) = arrData(1, jcol)
                End If
            Next jcol
            .Range(strArr(i)).Rows(2) = Application.Index(arrData, 2, 0)
        Next i
    End With
  
End Sub

 

[howard]

Hi Alex

Many thanks. Code is faster than my original code

I had forgotten to name raage "NP4_AUT" Have attached updated workbook containing this range

Branch Profits.xlsm

Shared with Dropbox

www.dropbox.com