VBA宏性能太慢

Question

我从另一张表（ADMIN_ARB11）中填写两张（Testfall-Input_Vorschlag）和（Testfall-Input_Antrag）的随机值。

我在表格中有371行（Testfall-Input_Vorschlag）我在表格中有488行（Testfall-Input_Antrag）

我在工作表（ADMIN_ARB11）中有859列。

我从第一个371列（来自ADMIN_ARB11）中选择一个随机值，然后将它们放入工作表中的371行（Testfall-Input_Vorschlag），然后从接下来的488列（来自ADMIN_ARB11）中选择一个随机值，将它们放入工作表中的488行（Testfall-Input_Antrag）。 为此，我制定了一个代码。

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

它按预期工作，但运行代码需要5分钟。 我该如何优化呢？

Answer 1

根据我的经验，直接写入细胞是一个昂贵的过程。 相反，您可以设置一个形状类似于您想要填充的范围的数组，然后用您的值填充数组 ，最后将数组放入范围中，例如

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

vArr(1, 1) = someValue

...

Range("A1:ZZ300") = vArr

通常这会使事情加快90-95％。 您可以在此处找到更多信息： http ： //www.mrexcel.com/forum/excel-questions/71620-assign-range-cells-array.html

在这里： http ： //www.cpearson.com/excel/ArraysAndRanges.aspx

Answer 2

其他一些速度提示可以在这里找到： http ： //www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html