VBA Macro suddenly extremely slow. Need help in how to edit it.

ThePirateKing · Jul 16, 2024

I have this code where it computes stress; previously, it was inputted as a direct formula in the cell, but now I want to convert all the cell formulas into VBA code. The code is working but is extremely slow. I am not good at VBA coding, and most of the code was from the internet.

Please help me clean this up so it runs much faster.

VBA Code:

'========================================================================
'
' 応力計算
'
'========================================================================

Sub 応力計算()

    Windows(outFile2).Activate
   
   
    For i = 1 To Items
   
        Workbooks(mainFN).Sheets("初期メニュー").Cells(10, 10) = B_NAME(i)
      
        If CALC(i) = 0 Then
            GoTo Nistep
        End If
   
        For j = 1 To 10
       
        Workbooks(mainFN).Sheets("初期メニュー").Cells(10, 11) = j

            If MEM(i, j) = "" Then
                GoTo Njstep
            End If

        Sheets(SNAME(i, j, 1)).Select

        K = 22  ' 応力計算開始位置（開始行）

応力:   ' 応力計算開始

        Count = Sheets(SNAME(i, j, 1)).Cells(K, 1)

        If Count = "" Then
            GoTo Njstep
        End If
       
        Workbooks(mainFN).Sheets("初期メニュー").Cells(10, 12) = K
       
    ' 部材力読み取り
      Yie1 = Sheets(SNAME(i, j, 1)).Cells(6, 5)
         N = Sheets(SNAME(i, j, 1)).Cells(K, 3)
        Qy = Sheets(SNAME(i, j, 1)).Cells(K, 4)
        Qz = Sheets(SNAME(i, j, 1)).Cells(K, 5)
         T = Sheets(SNAME(i, j, 1)).Cells(K, 6) * 100
        My = Sheets(SNAME(i, j, 1)).Cells(K, 7) * 100
        Mz = Sheets(SNAME(i, j, 1)).Cells(K, 8) * 100

    ' 休業時判断

        Cond = Sheets(SNAME(i, j, 1)).Cells(K, 2)

        'If cond = "C(休業時)" Then Om = Osom(i)
        'Om = Opeom(i)
       
        If Cond = "C(休業時)" Then
            Om = Osom(i)
        Else
            Om = Opeom(i)
        End If

    ' 垂直応力

        SN = N / a(i)

    '圧縮,引張りの判断（ωの処理）

        'If SN < 0 Then SN = SN * Om
   
    'せん断応力の算出
   
        Ty = Abs(Qy) / Ay(i)
        Tz = Abs(Qz) / Az(i)

        TTy = Abs(T) / (2 * A0(i) * Yt(i))
        TTz = Abs(T) / (2 * A0(i) * Zt(i))
   
    'トルクによるせん断力の判定
   
        If TTy + Ty > TTz + Tz Then
            Te = Ty + TTy
            FLAG = "Y"     ': GoTo JJ2
        Else
            Te = Tz + TTz
            FLAG = "Z"
        End If

JJ2:

        SMy = Abs(My / Zy(i))
        SMz = Abs(Mz / Zz(i))
      
       
    'KN/cm^2 ----> N/mm^2
       
        SN = SN * 10
        SMy = SMy * 10
        SMz = SMz * 10
       
        'ST = ST * 10
        'SC = SC * 10
       
        Ty = Ty * 10
        Tz = Tz * 10
       
        TTy = TTy * 10
        TTz = TTz * 10
       
        Te = Te * 10
       

'Added 24.06.05
        CB1 = (My * 10 / (Iy(i) / Z1(i)) * -1) + (Mz * 10 / (Iz(i) / Y1(i)) * -1)
        CB2 = (My * 10 / (Iy(i) / Z2(i)) * -1) + (Mz * 10 / (Iz(i) / Y2(i)) * -1)
        CB3 = (My * 10 / (Iy(i) / Z3(i)) * -1) + (Mz * 10 / (Iz(i) / Y3(i)) * -1)
        CB4 = (My * 10 / (Iy(i) / Z4(i)) * -1) + (Mz * 10 / (Iz(i) / Y4(i)) * -1)
       
        Ct1 = SN + CB1
        Ct2 = SN + CB2
        Ct3 = SN + CB3
        Ct4 = SN + CB4
       
        STi = WorksheetFunction.Max(Ct1, Ct2, Ct3, Ct4)
       
        If STi < 0 Then
            ST = 0
        Else
            ST = STi
        End If
       
       
        If ((SN * Om) + (0.9 * CB1)) < 0 Then
            Cc1 = (SN * Om) + (0.9 * CB1)
        Else
            Cc1 = SN + CB1
        End If
           
        If ((SN * Om) + (0.9 * CB2)) < 0 Then
            Cc2 = (SN * Om) + (0.9 * CB2)
        Else
            Cc2 = SN + CB2
        End If
           
        If ((SN * Om) + (0.9 * CB3)) < 0 Then
            Cc3 = (SN * Om) + (0.9 * CB3)
        Else
            Cc3 = SN + CB3
        End If
           
        If ((SN * Om) + (0.9 * CB4)) < 0 Then
            Cc4 = (SN * Om) + (0.9 * CB4)
        Else
            Cc4 = SN + CB4
        End If
       
       
        SCi = WorksheetFunction.Min(Cc1, Cc2, Cc3, Cc4)
       
        If SCi > 0 Then
            SC = 0
        Else
            SC = SCi
        End If
       
        STe = Sqr(ST ^ 2 + 3 * Te ^ 2)
        SCe = Sqr(SC ^ 2 + 3 * Te ^ 2)
       
        SST = Abs(STe)
        SSC = Abs(SCe)
       
        If SST >= SSC Then
            SSe = SST
        Else
            SSe = SSC
        End If
       
        STe = STe * 10
        SCe = SCe * 10
       
        SSe = SSe * 10
   
        If Cond = "A" Then
            Fac = 1.5
        ElseIf Cond = "B" Then
            Fac = 1.304
        ElseIf Cond = "C" Or Cond = "C(休業時)" Then
            Fac = 1.154
        Else
            Fac = "error"
        End If
       
        Yie2 = Yie1 / 1.154
        Yie3 = Yie1 / 1.5
       
        If N > 0 Then
            S1 = ((N * 10) / a(i)) / (Yie1 / Fac)
        Else
            S1 = ((N * 10) / a(i)) / (Yie2 / Fac)
        End If
       
        Sbyz = SMy + SMz
        If Sbyz < 0 Then
            S2 = Sbyz
        Else
            S2 = Sbyz / (Yie1 / Fac)
        End If
       
        If Sbyz < 0 Then
            S3 = Sbyz
        Else
            S3 = Sbyz / (Yie2 / Fac)
        End If
       
        S4i = Abs(Ty) / (Yie3 / Fac)
        S4r = Abs(Tz) / (Yie3 / Fac)
        S4 = WorksheetFunction.Max(S4i, S4r)
   
        S5i = Abs(TTy) / (Yie3 / Fac)
        S5r = Abs(TTz) / (Yie3 / Fac)
        S5 = WorksheetFunction.Max(S5i, S5r)
       
        If Abs(Ty) > Abs(Tz) Then
            S6i = Ty
        Else
            S6i = Tz
        End If
       
        If Ft(i) < Wt(i) Then
            S6r = TTy
        Else
            S6r = TTz
        End If
       
        S6 = (S6i + S6r) / (Yie3 / Fac)
       

        S7 = Abs(ST / (Yie1 / Fac))
       
        If N > 0 Then
            S8 = 0
        Else
            S8 = Abs(SC / (Yie1 / Fac))
        End If
       
        IRM = WorksheetFunction.Max(S1, S2, S3, S4, S5, S6, S7, S8)
   
    '計算結果転記
   
        Sheets(SNAME(i, j, 1)).Cells(K, 9) = SN
        Sheets(SNAME(i, j, 1)).Cells(K, 10) = SMy
        Sheets(SNAME(i, j, 1)).Cells(K, 11) = SMz

        Sheets(SNAME(i, j, 1)).Cells(K, 12) = ST
        Sheets(SNAME(i, j, 1)).Cells(K, 13) = SC
   
        Sheets(SNAME(i, j, 1)).Cells(K, 14) = Ty
        Sheets(SNAME(i, j, 1)).Cells(K, 15) = Tz

        Sheets(SNAME(i, j, 1)).Cells(K, 16) = TTy
        Sheets(SNAME(i, j, 1)).Cells(K, 17) = TTz

        Sheets(SNAME(i, j, 1)).Cells(K, 18) = Te

        Sheets(SNAME(i, j, 1)).Cells(K, 19) = STe
        Sheets(SNAME(i, j, 1)).Cells(K, 20) = SCe

        Sheets(SNAME(i, j, 1)).Cells(K, 21) = SSe
 'Added 24.06.05
        Sheets(SNAME(i, j, 1)).Cells(K, 23) = CB1
        Sheets(SNAME(i, j, 1)).Cells(K, 24) = CB2
        Sheets(SNAME(i, j, 1)).Cells(K, 26) = CB3
        Sheets(SNAME(i, j, 1)).Cells(K, 27) = CB4
       
        Sheets(SNAME(i, j, 1)).Cells(K, 30) = IRM
       
        Sheets(SNAME(i, j, 1)).Cells(K, 32) = Fac
        Sheets(SNAME(i, j, 1)).Cells(K, 33) = S1
        Sheets(SNAME(i, j, 1)).Cells(K, 34) = S2
        Sheets(SNAME(i, j, 1)).Cells(K, 35) = S3
        Sheets(SNAME(i, j, 1)).Cells(K, 36) = S4
        Sheets(SNAME(i, j, 1)).Cells(K, 37) = S5
        Sheets(SNAME(i, j, 1)).Cells(K, 38) = S6
        Sheets(SNAME(i, j, 1)).Cells(K, 39) = S7
        Sheets(SNAME(i, j, 1)).Cells(K, 40) = S8

        K = K + 1   ' 応力計算位置カウント

        GoTo 応力

Njstep:
        Next j

Nistep:
    Next i
   
End Sub

bobsan42 · Jul 16, 2024

It is a tedious task to go through your code, even when I discard the Japanese.
It is unclear what are many of the things inside it and where do they come from e.g. B_NAME(i), MEM(i, j), SNAME(i, j, 1), Osom(i), Opeom(i), a(i), Ay(i), Zt(i), SN, ...................
It is really hard to talk about optimizing something I cannot understand completely, however I will give it a shot:

BASICS RULES:

Avoid .Select method if not really necessary
Read/Write clusters of cells where possible instead of one at a time e.g.
VBA Code:
```
Sheets(SNAME(i, j, 1)).Cells(k, 9).Resize(1,3) = ARRAY(SN, SMy, SMz)
```
Use constants where possible
Use variables to store objects, arrays, values etc. and reuse them e.g.
VBA Code:
```
set shName = SNAME(i,j,1)
```
Avoid long procedures and functions. Break it down into small manageable pieces where possible.

MAIN PROBLEM (Although I may be misunderstanding your code so I may be wrong):

I believe you have setup a sheet with some formulas and calculations, then you pass values to the sheet, then you get the results from the sheet and use them again.

If the above is actually true you may get a MAJOR boost if you make all your calculations in memory and avoid waiting for the sheet calculations to complete.

ThePirateKing · Jul 17, 2024

Thank you @bobsan42 , after using below code , it below code it become a little faster. from 10-15mins run, now 5-6mins

Sheets(SNAME(i, j, 1)).Cells(k, 9).Resize(1,3) = ARRAY(SN, SMy, SMz)

bobsan42 · Jul 17, 2024

You can apply this approach to other bits of your code as well:

VBA Code:

Sheets(SNAME(i, j, 1)).Cells(k, 9).Resize(1, 13) = Array(SN, SMy, SMz, ST, SC, Ty, Tz, TTy, TTz, te, STe, SCe, SSe)
Sheets(SNAME(i, j, 1)).Cells(k, 32).Resize(1, 9) = Array(Fac, S1, S2, S3, S4, S5, S6, S7, S8)

you can also do something similar for the data reading:

VBA Code:

        x = Sheets(SNAME(i, j, 1)).Cells(k, 3).Resize(1, 6)
            n = x(1, 1)
            Qy = x(1, 2)
            Qz = x(1, 3)
            T = x(1, 4)
            My = x(1, 5)
            Mz = x(1, 6)

VBA Macro suddenly extremely slow. Need help in how to edit it.

ThePirateKing

New Member

Excel Facts

bobsan42

Well-known Member

ThePirateKing

New Member

bobsan42

Well-known Member

Similar threads

Forum statistics

Share this page

VBA Macro suddenly extremely slow. Need help in how to edit it.

ThePirateKing

New Member

Excel Facts

bobsan42

Well-known Member

ThePirateKing

New Member

bobsan42

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock