increase vba excel code efficiency - maximize speed - minimize calculation time

Z

Zacharia

New Member
Joined
Jul 4, 2016
Messages
36
Hello,
I am looking to increase my code's efficiency to maximize the speed, to minimize the calculation time. I have two ideas to increase the efficiency/decrease calc time.

1) Currently I am using a Do Until Loop that references various worksheets in various workbooks based on workbook names and worksheet names in the cell range A1:F11 of wb"Cntrl".ws"Cntrl2." These worksheets are set as array1 through array6. These arrays are summed in my For Next Loop within the Do Until Loop. Each of the Do Until Loops changes the values within each of the arrays. So each of the Do Until Loops changes the range that each of the arrays are set to. If it is possible, I think it would be faster to set the arrays from the beginning and instead of referencing the workbook names and worksheet names in the cell range A1:F11 I could reference the combination of arrays to sum. In other words does VBA allow
this sort of referencing. So for example in my For Next Loop I invision something like this;

arrSum(x, y) = RngRef1(x, y) + RngRef2(x, y) + RngRef3(x, y) + RngRef4(x, y) + RngRef5(x, y) + RngRef6(x, y)

2) I am passing the If arrSum = 6, the countPos values, to ws"Pos1." I think would be faster if I could pass the values to another array, for example arrPos(x, y). How can I do this? I tried this to no success;

For x = 1 To UBound(arr1, 1)
countPos = 0
For y = 1 To UBound(arr1, 2)
arrSum(x, y) = arr1(x, y) + arr2(x, y) + arr3(x, y) + arr4(x, y) + arr5(x, y) + arr6(x, y)
If arrSum(x, y) = "6" Then countPos = countPos + 1
Next y
arrPos(x, y) = countPos
Next x

Here is my complete code without the above possible changes.
Thanks for any input!!
Zacharia

Code: 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Define and Set for the Do Until Loops                                       '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim ws0 As Worksheet
     Set ws0 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2")
      
    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim rng4 As Range, rng5 As Range, rng6 As Range
    Dim rngSum As Range
     Set rngSum = Workbooks("Cntrl.xlsm").Sheets("Cntrl3").Range("B5:BDD587")
     
    Dim countPos1 As Range, countNeg1 As Range
     Set countPos1 = Workbooks("Cntrl.xlsm").Sheets("Pos1").Range("A1")
     Set countNeg1 = Workbooks("Cntrl.xlsm").Sheets("Neg1").Range("A1")
     
    Dim arr1 As Variant, arr2 As Variant, arr3 As Variant
    Dim arr4 As Variant, arr5 As Variant, arr6 As Variant
    Dim arrSum As Variant
    
    Dim RngRef1 As Range, RngRef2 As Range, RngRef3 As Range
    Dim RngRef4 As Range, RngRef5 As Range, RngRef6 As Range
     Set RngRef1 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("A2")
     Set RngRef2 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("B2")
     Set RngRef3 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("C2")
     Set RngRef4 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("D2")
     Set RngRef5 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("E2")
     Set RngRef6 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("F2")
        
      iOffset = 0
      jOffset = 0
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Loop Through Each Combination                                               '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 Do Until IsEmpty(RngRef1)
 
    sTmp1 = RngRef1.Value: sTmp2 = RngRef2.Value: sTmp3 = RngRef3.Value
    sTmp4 = RngRef4.Value: sTmp5 = RngRef5.Value: sTmp6 = RngRef6.Value
     Set rng1 = Workbooks(ws0.Range("A1").Value).Sheets(sTmp1).Range("B5:BDD587")
     Set rng2 = Workbooks(ws0.Range("B1").Value).Sheets(sTmp2).Range("B5:BDD587")
     Set rng3 = Workbooks(ws0.Range("C1").Value).Sheets(sTmp3).Range("B5:BDD587")
     Set rng4 = Workbooks(ws0.Range("D1").Value).Sheets(sTmp4).Range("B5:BDD587")
     Set rng5 = Workbooks(ws0.Range("E1").Value).Sheets(sTmp5).Range("B5:BDD587")
     Set rng6 = Workbooks(ws0.Range("F1").Value).Sheets(sTmp6).Range("B5:BDD587")
      
      arr1 = rng1.Value: arr2 = rng2.Value: arr3 = rng3.Value
      arr4 = rng4.Value: arr5 = rng5.Value: arr6 = rng6.Value
      arrSum = rngSum.Value
 Workbooks("Cntrl.xlsm").Sheets("Pos1").Activate
 countPos1.Select
   
    For x = 1 To UBound(arr1, 1)
    countPos = 0
        For y = 1 To UBound(arr1, 2)
            arrSum(x, y) = arr1(x, y) + arr2(x, y) + arr3(x, y) + arr4(x, y) + arr5(x, y) + arr6(x, y)
            If arrSum(x, y) = "6" Then countPos = countPos + 1
        Next y
            ActiveCell.Range("A1").Value = countPos
            ActiveCell.Offset(1, 0).Range("A1").Select
    Next x
    
 Workbooks("Cntrl.xlsm").Sheets("Neg1").Activate
 countNeg1.Select
    
  For x = 1 To UBound(arr1, 1)
  countNeg = 0
        For y = 1 To UBound(arr1, 2)
            If arrSum(x, y) = "-6" Then countNeg = countNeg + 1
        Next y
            ActiveCell.Range("A1").Value = countNeg
            ActiveCell.Offset(1, 0).Range("A1").Select
    Next x
    
      iOffset = iOffset + 1
      jOffset = jOffset + 1
        
     Set RngRef1 = ws0.Range("A2").Offset(iOffset, 0)
     Set RngRef2 = ws0.Range("B2").Offset(iOffset, 0)
     Set RngRef3 = ws0.Range("C2").Offset(iOffset, 0)
     Set RngRef4 = ws0.Range("D2").Offset(iOffset, 0)
     Set RngRef5 = ws0.Range("E2").Offset(iOffset, 0)
     Set RngRef6 = ws0.Range("F2").Offset(iOffset, 0)
     Set countPos1 = Sheets("Pos1").Range("A1").Offset(0, jOffset)
     Set countNeg1 = Sheets("Neg1").Range("A1").Offset(0, jOffset)
 
 Loop
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Create Analytical Data                                                      '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Workbooks("Cntrl.xlsm").Sheets("Percentile").Activate
        Range("A1").Select
        ActiveCell.FormulaR1C1 = "=IF(ISERROR(Pos1!RC/(Pos1!RC+Neg1!RC)),0,Pos1!RC/(Pos1!RC+Neg1!RC))"
        Selection.Copy
        ActiveCell.Range("A1:P583").Select
        ActiveSheet.Paste
 
Sort by date Sort by votes
A couple of thoughts ....

1. The slow parts of your code will be the VBA/Excel interface, so you should avoid .Activate, .Select, .Selection, ActiveSheet etc - they're inefficient and prone to error.

For example, you can replace:

Code: 
Range("A1").Select
ActiveCell.FormulaR1C1 = "=IF(ISERROR(Pos1!RC/(Pos1!RC+Neg1!RC)),0,Pos1!RC/(Pos1!RC+Neg1!RC))"
Selection.Copy
ActiveCell.Range("A1:P583").Select
ActiveSheet.Paste

'with

Workbooks("Cntrl.xlsm").Sheets("Percentile").Range("A1:P583").Formula = "=IFERROR('Pos1'!A1/('Pos1'!A1+'Neg1'!A1),0)"

2. You loop twice here when one loop will suffice:

Code: 
Workbooks("Cntrl.xlsm").Sheets("Pos1").Activate
countPos1.Select

For x = 1 To UBound(arr1, 1)
    countPos = 0
    For y = 1 To UBound(arr1, 2)
        arrSum(x, y) = arr1(x, y) + arr2(x, y) + arr3(x, y) + arr4(x, y) + arr5(x, y) + arr6(x, y)
        If arrSum(x, y) = "6" Then countPos = countPos + 1
    Next y
    ActiveCell.Range("A1").Value = countPos
    ActiveCell.Offset(1, 0).Range("A1").Select
Next x

Workbooks("Cntrl.xlsm").Sheets("Neg1").Activate
countNeg1.Select

For x = 1 To UBound(arr1, 1)
countNeg = 0
    For y = 1 To UBound(arr1, 2)
        If arrSum(x, y) = "-6" Then countNeg = countNeg + 1
    Next y
    ActiveCell.Range("A1").Value = countNeg
    ActiveCell.Offset(1, 0).Range("A1").Select
Next x

Instead, perhaps:

Code: 
Dim countPos() As Long, countNeg() As Long

'after populating arr1
ReDim countPos(1 To UBound(arr1))
ReDim countNeg(1 To UBound(arr1))

'.....

For x = 1 To UBound(arr1)
    For y = 1 To UBound(arr1, 2)
        arrSum(x, y) = arr1(x, y) + arr2(x, y) + arr3(x, y) + arr4(x, y) + arr5(x, y) + arr6(x, y)
        Select Case arrSum(x, y)
        Case 6
            countPos(x) = countPos(x) + 1
        Case -6
            countNeg(x) = countNeg(x) + 1
        End Select
    Next y
    With Workbooks("Cntrl.xlsm")
        .Sheets("Pos1").Range("A1").Resize(UBound(arr1)).Value = Application.Transpose(countPos)
        .Sheets("Neg1").Range("A1").Resize(UBound(arr1)).Value = Application.Transpose(countNeg)
    End With
Next x

3. All this type of stuff will be slow:

Code: 
iOffset = iOffset + 1
jOffset = jOffset + 1
   
Set RngRef1 = ws0.Range("A2").Offset(iOffset, 0)
Set RngRef2 = ws0.Range("B2").Offset(iOffset, 0)
Set RngRef3 = ws0.Range("C2").Offset(iOffset, 0)
Set RngRef4 = ws0.Range("D2").Offset(iOffset, 0)
Set RngRef5 = ws0.Range("E2").Offset(iOffset, 0)
Set RngRef6 = ws0.Range("F2").Offset(iOffset, 0)

I'd be inclined to load everything into VBA, and structure the code like this:

Code: 
Sub NOT_Tested()

    Dim wb(1 To 6) As Workbook
    Dim vArr(1 To 6) As Variant, vSheetNames As Variant
    
    With Workbooks("Cntrl.xlsm").Sheets("Cntrl2")
        vSheetNames = .Range("A2:F" & .Range("A2").End(xlDown).Row)
        For j = 1 To 6
            Set wb(j) = .Cells(1, j).Value
        Next j
        For i = 1 To UBound(vSheetNames)
            For j = 1 To 6
                vArr(j) = wb(j).Worksheets(vSheetNames(i, j)).Range("B5:BDD587").Value
            Next j
            'loop through x and y, doing stuff with vArr(1)(x,y) to vArr(6)(x,y)
        Next i
    End With

End Sub
 
Upvote 0
StephenCrump,
Thank you for your suggestions! I successfully incorporated your first suggestion, so as not to go back and forth with VBA and Excel interface. And I also successfully incorporated your second suggestion to go from two loops to one loop. One note on that, because each combination is calculated in each column I added .Offset(0, jOffset). Your last suggestion, to load everything into VBA first, has proved to be a bit of a challenge for me. Pushing my VBA understanding. After working through a few issues I am stuck at error code 424 for the line that reads;

set wb(j) = .Cells(1, j).Value

Any recommendations to clear up this error?

Thanks for your expertise!!

Here is my revised code...
Code: 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Define and Set For Next Loops                                               
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim wb(1 To 6) As Workbook
    Dim vArr(1 To 6) As Variant, vSheetNames As Variant
    Dim countPos() As Long, countNeg() As Long
    
    Dim rngSum As Range
    Dim arrSum As Variant
     Set rngSum = Workbooks("Cntrl.xlsm").Sheets("Cntrl3").Range("B5:BDD587")
     arrSum = rngSum.Value
     
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Load Ranges Into Arrays                                                     
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 With Workbooks("Cntrl.xlsm").Sheets("Cntrl2")
 vSheetNames = .Range("A2:F" & .Range("A2").End(xlDown).Row)
    
        For j = 1 To 6
            Set wb(j) = .Cells(1, j).Value
        Next j
    
    For i = 1 To UBound(vSheetNames)
        
        For j = 1 To 6
            vArr(j) = wb(j).Worksheets(vSheetNames(i, j)).Range("B5:BDD587").Value
        Next j
       
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Loop Through Each Combination                                               
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ReDim countPos(1 To UBound(vArr(j)))
        ReDim countNeg(1 To UBound(vArr(j)))
        For x = 1 To UBound(vArr)
        For y = 1 To UBound(vArr, 2)
            arrSum(x, y) = vArr(1)(x, y) + vArr(2)(x, y) + vArr(3)(x, y) + vArr(4)(x, y) + vArr(5)(x, y) + vArr(6)(x, y)
                Select Case arrSum(x, y)
                    Case 6
                        countPos(x) = countPos(x) + 1
                    Case -6
                        countNeg(x) = countNeg(x) + 1
                End Select
        Next y
            With Workbooks("Cntrl.xlsm")
                .Sheets("Pos1").Range("A1").Offset(0, jOffset).Resize(UBound(arr1)).Value = Application.Transpose(countPos)
                .Sheets("Neg1").Range("A1").Offset(0, jOffset).Resize(UBound(arr1)).Value = Application.Transpose(countNeg)
            End With
        Next x
        jOffset = jOffset + 1
            
    Next i
    
 End With
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Create Analytical Data                                                      
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Workbooks("Cntrl.xlsm").Sheets("Percentile").Range("A1:J583").Formula = "=IFERROR('Pos1'!A1/('Pos1'!A1+'Neg1'!A1),0)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B1:K1").Formula = "=SUM('Pos1'!A1:A583)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B2:K2").Formula = "=SUM('Neg1'!A1:A583)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B3:K3").Formula = "=B1/(B1+B2)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B5:K5").Formula = "=COUNTIF(Percentile!A1:A583,"">""&.5)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B6:K6").Formula = "=COUNTIF(Percentile!A1:A583,"">""&.9)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B7:K7").Formula = "=COUNTIF(Percentile!A1:A583,""=""&1)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B9:K9").Formula = "=AVERAGE(Percentile!A1:A583)"
 
Upvote 0
Oops sorry, I should have said:

Set wb(j) = Workbooks(Cells(1, j).Value)

Based on your original code, I have assumed that in Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("A1:F1") you have the names of six workbooks that are currently open in Excel, i.e. the codes correspond as highlighted below in red:

Code: 
'My code
With Workbooks("Cntrl.xlsm").Sheets("Cntrl2")
    '...
    For j = 1 To 6
[B][COLOR=#ff0000]      Set wb(j) = Workbooks(.Cells(1, j).Value)[/COLOR][/B]
    Next j

'Your code
Set ws0 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2")
'...
Set rng1 = [COLOR=#ff0000][B]Workbooks(ws0.Range("A1").Value)[/B][/COLOR].Sheets(sTmp1).Range("B5:BDD587")
Set rng2 = [COLOR=#ff0000][B]Workbooks(ws0.Range("B1").Value)[/B][/COLOR].Sheets(sTmp2).Range("B5:BDD587")
Set rng3 = [COLOR=#ff0000][B]Workbooks(ws0.Range("C1").Value)[/B][/COLOR].Sheets(sTmp3).Range("B5:BDD587")
Set rng4 = [COLOR=#ff0000][B]Workbooks(ws0.Range("D1").Value)[/B][/COLOR].Sheets(sTmp4).Range("B5:BDD587")
Set rng5 = [COLOR=#ff0000][B]Workbooks(ws0.Range("E1").Value)[/B][/COLOR].Sheets(sTmp5).Range("B5:BDD587")
Set rng6 = [COLOR=#ff0000][B]Workbooks(ws0.Range("F1").Value)[/B][/COLOR].Sheets(sTmp6).Range("B5:BDD587")
 
Upvote 0
Ah yes, that seems to fix it.
So now the code runs. But I am not getting the correct results.

This code works:
Code: 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Define and Set for the Do Until Loops                                       
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim ws0 As Worksheet
     Set ws0 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2")
     
    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim rng4 As Range, rng5 As Range, rng6 As Range
    Dim rngSum As Range
     Set rngSum = Workbooks("Cntrl.xlsm").Sheets("Cntrl3").Range("B5:BDD587")
     
    Dim arr1 As Variant, arr2 As Variant, arr3 As Variant
    Dim arr4 As Variant, arr5 As Variant, arr6 As Variant
    Dim arrSum As Variant
    
    Dim countPos() As Long, countNeg() As Long
    
    Dim RngRef1 As Range, RngRef2 As Range, RngRef3 As Range
    Dim RngRef4 As Range, RngRef5 As Range, RngRef6 As Range
     Set RngRef1 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("A2")
     Set RngRef2 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("B2")
     Set RngRef3 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("C2")
     Set RngRef4 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("D2")
     Set RngRef5 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("E2")
     Set RngRef6 = Workbooks("Cntrl.xlsm").Sheets("Cntrl2").Range("F2")
        
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Loop Through Each Combination                                               
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 Do Until IsEmpty(RngRef1)
 
    sTmp1 = RngRef1.Value: sTmp2 = RngRef2.Value: sTmp3 = RngRef3.Value
    sTmp4 = RngRef4.Value: sTmp5 = RngRef5.Value: sTmp6 = RngRef6.Value
     Set rng1 = Workbooks(ws0.Range("A1").Value).Sheets(sTmp1).Range("B5:BDD587")
     Set rng2 = Workbooks(ws0.Range("B1").Value).Sheets(sTmp2).Range("B5:BDD587")
     Set rng3 = Workbooks(ws0.Range("C1").Value).Sheets(sTmp3).Range("B5:BDD587")
     Set rng4 = Workbooks(ws0.Range("D1").Value).Sheets(sTmp4).Range("B5:BDD587")
     Set rng5 = Workbooks(ws0.Range("E1").Value).Sheets(sTmp5).Range("B5:BDD587")
     Set rng6 = Workbooks(ws0.Range("F1").Value).Sheets(sTmp6).Range("B5:BDD587")
      
      arr1 = rng1.Value: arr2 = rng2.Value: arr3 = rng3.Value
      arr4 = rng4.Value: arr5 = rng5.Value: arr6 = rng6.Value
      arrSum = rngSum.Value
     ReDim countPos(1 To UBound(arr1))
     ReDim countNeg(1 To UBound(arr1))
    For x = 1 To UBound(arr1)
    For y = 1 To UBound(arr1, 2)
        arrSum(x, y) = arr1(x, y) + arr2(x, y) + arr3(x, y) + arr4(x, y) + arr5(x, y) + arr6(x, y)
            Select Case arrSum(x, y)
                Case 6
                    countPos(x) = countPos(x) + 1
                Case -6
                    countNeg(x) = countNeg(x) + 1
            End Select
    Next y
        With Workbooks("Cntrl.xlsm")
            .Sheets("Pos1").Range("A1").Offset(0, jOffset).Resize(UBound(arr1)).Value = Application.Transpose(countPos)
            .Sheets("Neg1").Range("A1").Offset(0, jOffset).Resize(UBound(arr1)).Value = Application.Transpose(countNeg)
        End With
    Next x
      jOffset = jOffset + 1
      iOffset = iOffset + 1
     Set RngRef1 = ws0.Range("A2").Offset(iOffset, 0)
     Set RngRef2 = ws0.Range("B2").Offset(iOffset, 0)
     Set RngRef3 = ws0.Range("C2").Offset(iOffset, 0)
     Set RngRef4 = ws0.Range("D2").Offset(iOffset, 0)
     Set RngRef5 = ws0.Range("E2").Offset(iOffset, 0)
     Set RngRef6 = ws0.Range("F2").Offset(iOffset, 0)
 
 Loop
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Create Analytical Data                                                      
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Workbooks("Cntrl.xlsm").Sheets("Percentile").Range("A1:J583").Formula = "=IFERROR('Pos1'!A1/('Pos1'!A1+'Neg1'!A1),0)"
        Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B1:K1").Formula = "=SUM('Pos1'!A1:A583)"
        Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B2:K2").Formula = "=SUM('Neg1'!A1:A583)"
        Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B3:K3").Formula = "=B1/(B1+B2)"
        Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B5:K5").Formula = "=COUNTIF(Percentile!A1:A583,"">""&.5)"
        Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B6:K6").Formula = "=COUNTIF(Percentile!A1:A583,"">""&.9)"
        Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B7:K7").Formula = "=COUNTIF(Percentile!A1:A583,""=""&1)"
        Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B9:K9").Formula = "=AVERAGE(Percentile!A1:A583)"

This code does not work:
Code: 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Define and Set For Next Loops                                               
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim wb(1 To 6) As Workbook
    Dim vArr(1 To 6) As Variant, vSheetNames As Variant
    Dim countPos() As Long, countNeg() As Long
    
    Dim rngSum As Range
    Dim arrSum As Variant
     Set rngSum = Workbooks("Cntrl.xlsm").Sheets("Cntrl3").Range("B5:BDD587")
     arrSum = rngSum.Value
     
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Load Ranges Into Arrays                                                     
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 With Workbooks("Cntrl.xlsm").Sheets("Cntrl2")
 vSheetNames = .Range("A2:F" & .Range("A2").End(xlDown).Row)
    
        For j = 1 To 6
            Set wb(j) = Workbooks(.Cells(1, j).Value)
        Next j
    
    For i = 1 To UBound(vSheetNames)
        
        For j = 1 To 6
            vArr(j) = wb(j).Worksheets(vSheetNames(i, j)).Range("B5:BDD587").Value
        Next j
       
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Loop Through Each Combination                                               
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ReDim countPos(1 To UBound(vArr()))
        ReDim countNeg(1 To UBound(vArr()))
        For x = 1 To UBound(vArr)
        For y = 1 To UBound(vArr)
            arrSum(x, y) = vArr(1)(x, y) + vArr(2)(x, y) + vArr(3)(x, y) + vArr(4)(x, y) + vArr(5)(x, y) + vArr(6)(x, y)
                Select Case arrSum(x, y)
                    Case 6
                        countPos(x) = countPos(x) + 1
                    Case -6
                        countNeg(x) = countNeg(x) + 1
                End Select
        Next y
            With Workbooks("Cntrl.xlsm")
                .Sheets("Pos1").Range("A1").Offset(0, jOffset).Resize(UBound(vArr())).Value = Application.Transpose(countPos)
                .Sheets("Neg1").Range("A1").Offset(0, jOffset).Resize(UBound(vArr())).Value = Application.Transpose(countNeg)
            End With
        Next x
        jOffset = jOffset + 1
            
    Next i
    
 End With
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   To Create Analytical Data                                                      
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Workbooks("Cntrl.xlsm").Sheets("Percentile").Range("A1:J583").Formula = "=IFERROR('Pos1'!A1/('Pos1'!A1+'Neg1'!A1),0)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B1:K1").Formula = "=SUM('Pos1'!A1:A583)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B2:K2").Formula = "=SUM('Neg1'!A1:A583)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B3:K3").Formula = "=B1/(B1+B2)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B5:K5").Formula = "=COUNTIF(Percentile!A1:A583,"">""&.5)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B6:K6").Formula = "=COUNTIF(Percentile!A1:A583,"">""&.9)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B7:K7").Formula = "=COUNTIF(Percentile!A1:A583,""=""&1)"
    Workbooks("Cntrl.xlsm").Sheets("Analytics").Range("B9:K9").Formula = "=AVERAGE(Percentile!A1:A583)"

Do you see anything in the later version that I am missing??
 
Upvote 0
You must log in or register to reply here.

Similar threads

dreen
  • Question Question
Increasing the speed of Index & Match in VBA
2
Replies
13
Views
5K
DanteAmor
DanteAmor
C
  • Question Question
Copy VBA code for Date picker from Original sheet to Copied Workbooks
Replies
0
Views
2K
Conell8383
C

Share this page

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
Back
Top