Как я могу оптимизировать этот макрос, который я скомпилировал в Excel 2010 на 2016 год? - PullRequest
Новая
       12

Как я могу оптимизировать этот макрос, который я скомпилировал в Excel 2010 на 2016 год?

0 голосов
/ 15 января 2019

У меня есть макрос, который ищет строку и, когда находит, копирует и вставляет в нее значения и форматы.

Это работает довольно медленно в 2016 году, конечно, в 2010 году. Я не смог понять, как обойти это. 

Sub CommandButton1_Click()
    Dim strsearch As String, lastline As Long, tocopy As Long

    strsearch = CStr(InputBox("enter the string to search for"))
    lastline = Range("A65536").End(xlUp).Row
    J = 190

    For i = 1 To lastline
        For Each c In Range("G" & i & ":Z" & i)
            If InStr(c.Text, strsearch) Then
                tocopy = 1
            End If
        Next c 

        If tocopy = 1 Then
            Range(Cells(i, 1), Cells(i, 6)).Copy
            Sheets("Report").Range("A" & J).PasteSpecial (xlValues)
            Sheets("Report").Range("A" & J).PasteSpecial (xlFormats)
            J = J + 1
        End If

        tocopy = 0
    Next i
End Sub

1 Ответ

0 голосов
/ 15 января 2019

Возможно, что-то подобное будет работать у вас быстро: 

Sub CommandButton1_Click()


    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rFind As Range
    Dim rCopy As Range
    Dim sFind As String
    Dim sFirst As String

    sFind = InputBox("Enter the string to search for:")
    If Len(sFind) = 0 Then Exit Sub 'Pressed cancel

    Set wb = ActiveWorkbook
    Set wsData = wb.ActiveSheet
    Set wsDest = wb.Worksheets("Report")

    With wsData.Range("G1:Z" & wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row)
        Set rFind = .Find(sFind, .Cells(.Rows.Count, .Columns.Count), xlValues, xlPart)
        If Not rFind Is Nothing Then
            sFirst = rFind.Address
            Set rCopy = rFind
            Do
                Set rCopy = Union(rCopy, rFind)
                Set rFind = .FindNext(rFind)
            Loop While rFind.Address <> sFirst

            Intersect(rCopy.Parent.Range("A:F"), rCopy.EntireRow).Copy
            wsDest.Range("A190").PasteSpecial xlPasteValues
            wsDest.Range("A190").PasteSpecial xlPasteFormats
        End If
    End With

End Sub
...