CODEWITHSUNDEEP
excelvba
Tai Lung
Tai Lung

Reputation: 89

VBA Macro performance is too slow

I fill out Random values in two sheets (Testfall-Input_Vorschlag) and (Testfall-Input_Antrag) out of another sheet (ADMIN_ARB11).

I have 371 rows in sheet (Testfall-Input_Vorschlag) & I have 488 rows in sheet (Testfall-Input_Antrag)

I have 859 columns in sheet (ADMIN_ARB11).

I pick a random value from each of the 1st 371 columns(from ADMIN_ARB11) and I put them in the 371 rows in sheet (Testfall-Input_Vorschlag) and then I pick a random value from each of the next 488 columns(from ADMIN_ARB11) and put them in 488 rows in sheet (Testfall-Input_Antrag). To achieve this I have formulated a code.

Sub Random_Befüllung_Vorschlag_ARB11()
Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, j As Long, LB As Long, UB As Long
Set sh1 = Sheets("Testfall-Input_Vorschlag")
Set sh2 = Sheets("ADMIN_ARB11")


Application.ScreenUpdating = False
    For j = 7 To 300
        LB = 2
        If sh1.Cells(1, j) = "ARB11" Or sh1.Cells(1, j) = "ARB13" Or sh1.Cells(1, j) = "FVB1" Or sh1.Cells(1, j) = "FVB1E" Or sh1.Cells(1, j) = "FVB4" Or sh1.Cells(1, j) = "FVB4E" Then
            sh1.Cells(2, j) = sh1.Cells(1, j) & "_Schicht 1"
            sh1.Cells(3, j) = "TPL maximale Eingaben"
            If j = 7 Then
                sh1.Cells(6, j) = 1
            Else
                sh1.Cells(6, j) = sh1.Cells(6, j - 1) + 1
            End If
            sh1.Cells(5, j) = "TF " & sh1.Cells(6, j)
            sh1.Cells(7, j) = "Test_GE"
            sh1.Cells(8, j) = "x"


            For i = 11 To 382
            UB = sh2.Cells(Rows.Count, i - 10).End(xlUp).Row 'i - 10 controls column in Admin start at col 1.

            sh1.Cells(i, j).Value = sh2.Cells(Int((UB - LB + 1) * Rnd + LB), i - 10)

            Next

        End If



    If sh1.Cells(1, j) = vbNullString Then
    Exit For
    End If
    Next
Application.ScreenUpdating = False
End Sub

Sub Random_Befüllung_Antrag_ARB11()
Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, j As Long, LB As Long, UB As Long
Dim wb As Workbook
Dim ws As Worksheet

Set wb = ThisWorkbook
Set ws = wb.Sheets("Testfall-Input_Vorschlag")
Set sh1 = Sheets("Testfall-Input_Antrag")
Set sh2 = Sheets("ADMIN_ARB11")


Application.ScreenUpdating = False
    'Testfallinfo in Testfall-Input_Antrag kopieren
    For j = 7 To 300
    If Sheets("Testfall-Input_Vorschlag").Cells(1, j) = "ARB11" Or Sheets("Testfall-Input_Vorschlag").Cells(1, j) = "ARB13" Or Sheets("Testfall-Input_Vorschlag").Cells(1, j) = "FVB1" Or Sheets("Testfall-Input_Vorschlag").Cells(1, j) = "FVB1E" Or Sheets("Testfall-Input_Vorschlag").Cells(1, j) = "FVB4" Or Sheets("Testfall-Input_Vorschlag").Cells(1, j) = "FVB4E" Then
    Union(ws.Cells(1, j), ws.Cells(2, j), ws.Cells(3, j), ws.Cells(4, j), ws.Cells(5, j), ws.Cells(6, j), ws.Cells(7, j), ws.Cells(8, j)).Copy
    sh1.Range("IV1").End(xlToLeft).Offset(, 1).PasteSpecial xlValues
    End If



        LB = 2
        If sh1.Cells(1, j) = "ARB11" Then
            For i = 13 To 501
                UB = sh2.Cells(Rows.Count, i + 364).End(xlUp).Row 'i - 10 controls column in Admin start at col 1.
                sh1.Cells(i, j).Value = sh2.Cells(Int((UB - LB + 1) * Rnd + LB), i + 364)


            Next
        End If

    If sh1.Cells(1, j) = vbNullString Then
    Exit For
    End If
    Next j
Application.ScreenUpdating = True
End Sub

It works as expected but it takes 5 min to run the code. How can I optimize this?

Upvotes: 1

Views: 1420

Answers (2)

Solar Mike
Solar Mike

Reputation: 8375

Some other hints for speed can be found here: http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html

Upvotes: 1

Gabor
Gabor

Reputation: 695

In my experience, writing to cells directly is an expensive procedure. Instead, you could set up an array shaped like the range you want to fill, then fill the array with your values, and finally put the array into the range, e.g.

Dim vArr(1 To 300, 1 To 250) As Variant

vArr(1, 1) = someValue

...

Range("A1:ZZ300") = vArr

Usually this speeds things up by 90-95%. You can find out more here: http://www.mrexcel.com/forum/excel-questions/71620-assign-range-cells-array.html

and here: http://www.cpearson.com/excel/ArraysAndRanges.aspx

Upvotes: 3

Related Questions