Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Как ускорить макрос?, Сопоставление таблиц
 
#1
06.12.2022 19:14:23
Добрый день!
Написал макрос для сопоставления двух таблиц и перенесения информации из одной в другую (из вкладки RSA в ASSAY) (типа ВПР, но с заменой некоторых знаков). Сейчас таблицы содержат 500 строк, и 47 столбцов. Процесс занимает секунд 20. В дальнейшем таблицы должны пополниться до 10к-50к строк, не поляжет ли мой макрос в итоге. Как ускорить?

Код
Sub Base_Grade_to_assay_RSA()

Dim NsAssay As Long
Dim NsSa As Long
Dim LastRowAssay As Long
Dim LastRowRsa As Long
Dim LastColAssay As Long
Dim LastColRsa As Long
Dim Value_Au As String
Dim Value_replace As String
LastRowAssay = Worksheets("ASSAY").Cells(Rows.Count, 1).End(xlUp).Row
LastRowRsa = Worksheets("RSA").Cells(Rows.Count, 1).End(xlUp).Row
LastColAssay = Worksheets("ASSAY").Cells(1, Columns.Count).End(xlToLeft).Column
LastColRsa = Worksheets("RSA").Cells(1, Columns.Count).End(xlToLeft).Column
Dim myPhrase As Variant
Dim myCellAssay As Range
Dim myCellSa As Range
Dim i As Long
ReDim arr1_Assay_Rsa(0 To LastColRsa) As Long
ReDim arr1_Rsa(0 To LastColRsa) As Long
Dim HeadAssay As Long
Dim HeadSa As Long
 

'Тут идет сопостовления шапок таблиц и сопостовление их по номеру колонки, чтоб не привязывать конкректную колонку к конкретной колонки в другой таблицы

For i = 1 To LastColRsa
    myPhrase = Worksheets("RSA").Cells(2, i)
    Set myCellAssay = Worksheets("ASSAY").Range("A2:BB2").Find(myPhrase, lookAt:=xlWhole)
    Set myCellSa = Worksheets("RSA").Range("A2:BB2").Find(myPhrase, lookAt:=xlWhole)
    arr1_Assay_Rsa(i - 1) = myCellAssay.Column
    arr1_Rsa(i - 1) = myCellSa.Column
Next


'По уникальному значению NS проходит цикл в таблицы ASSAY и потом еще проход по RSA по тому же полю если есть со впадения то замена символов если требуется.

Application.DisplayAlerts = False
    For NSAsssay = 3 To LastRowAssay
        For NsSa = 3 To LastRowRsa
            If Worksheets("ASSAY").Cells(NSAsssay, 6) = Worksheets("RSA").Cells(NsSa, 2) Then
                For i = 0 To LastColRsa - 1
                HeadSa = arr1_Rsa(i)
                HeadAssay = arr1_Assay_Rsa(i)
                Value_Au = Worksheets("RSA").Cells(NsSa, HeadSa)
                Value_replace = ">"
                    If InStr(1, Value_Au, Value_replace, vbTextCompare) > 0 Then
                        Value_Au = Replace(Value_Au, Value_replace, "")
                    End If
                Value_replace = " "
                    If InStr(1, Value_Au, Value_replace, vbTextCompare) > 0 Then
                        Value_Au = Replace(Value_Au, Value_replace, "")
                    End If
                Value_replace = "-"
                    If InStr(1, Value_Au, Value_replace, vbTextCompare) > 0 Then
                        Value_Au = Replace(Value_Au, Value_replace, "")
                    End If
                Value_replace = ","
                    If InStr(1, Value_Au, Value_replace, vbTextCompare) > 0 Then
                        Value_Au = Replace(Value_Au, Value_replace, ".")
                    End If
                Value_replace = "<"
                    If InStr(1, Value_Au, Value_replace, vbTextCompare) > 0 Then
                        Value_Au = Replace(Value_Au, Value_replace, "")
                        Value_Au = Value_Au / 2
                    End If
                Worksheets("ASSAY").Cells(NSAsssay, HeadAssay) = Value_Au
                Next
            End If
        Next
    Next
Application.DisplayAlerts = True
End Sub
Изменено: Renamed User - 06.12.2022 19:47:46
 
 
 
#2
06.12.2022 19:21:01
Renamed User,  код следует оформлять соответствующим тегом. Ищите кнопку <...> и сиправьте своё сообщение.
 
 
 
#3
06.12.2022 19:22:55
Цитата
Renamed User написал: Хотел прикрепить файл но он слишком тяжелый
А никому не нужен Ваш рабочий файл - создайте небольшой аналог.
 
 
 
#4
07.12.2022 10:16:33
Renamed User, здравствуйте
Цитата
Renamed User: Как ускорить?
работа с массивами вместо ячеек + словари вместо полного перебора сократит время с 20ти секунд до, примерно, одной или того меньше…
Если не хотите изучать эти инструменты сами - просто подождите и вам, скорее всего, сделают готовый макрос добрые местные  ;)
Изменено: Jack Famous - 07.12.2022 10:17:25
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#5
07.12.2022 11:41:20
Код
Sub Base_Grade_to_assay_RSA2()
    Dim dicX As Object
    Set dicX = GetDicX()
    If dicX.Count = 0 Then Exit Sub
    If Not dicX.Exists("NS") Then Exit Sub
    
    Dim arrASSAYColumns As Variant
    arrASSAYColumns = GetArrASSAYColumns(dicX)
    
    Dim xNS As Long
    xNS = WorksheetFunction.Match("NS", dicX.Keys(), 0)
    
    Dim dicY As Object
    Set dicY = GetDicY(arrASSAYColumns(xNS))
    
    Dim arrRSA As Variant
    arrRSA = Worksheets("RSA").ListObjects("йцу").Range
    xNS = WorksheetFunction.Match("NS", Worksheets("RSA").ListObjects("йцу").HeaderRowRange, 0)
    
    Dim hh As Long
    Dim ss As Variant
    Dim yRSA As Long
    Dim yASSAY As Long
    For yRSA = 2 To UBound(arrRSA)
        If dicY.Exists(arrRSA(yRSA, xNS)) Then
            yASSAY = dicY.Item(arrRSA(yRSA, xNS))
            
            For hh = LBound(arrASSAYColumns) To UBound(arrASSAYColumns)
                ss = arrASSAYColumns(hh)(yASSAY, 1)
                ss = Replace(ss, ">", "")
                ss = Replace(ss, " ", "")
                ss = Replace(ss, "-", "")
                ss = Replace(ss, ",", ".")
                If InStr(ss, "<") > 0 Then
                    ss = Replace(ss, "<", "")
                    On Error Resume Next
                    ss = ss / 2
                    On Error GoTo 0
                End If
                arrASSAYColumns(hh)(yASSAY, 1) = ss
            Next
        End If
    Next
    
    PrintArr arrASSAYColumns, dicX
    
End Sub

Private Sub PrintArr(arr As Variant, dicX As Object)
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim hh As Long
    Dim xx As Variant
    For Each xx In dicX.Items
        hh = hh + 1
        Worksheets("ASSAY").ListObjects("Assay").Range.Columns(xx).Value = arr(hh)
    Next
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub

Private Function GetDicY(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim yy As Long
    For yy = 2 To UBound(arr, 1)
        dic.Item(arr(yy, 1)) = yy
    Next
    
    Set GetDicY = dic
End Function

Private Function GetArrASSAYColumns(dicX As Object) As Variant
    Dim arr As Variant
    ReDim arr(1 To dicX.Count)
    
    Dim ii As Long
    Dim xx As Variant
    For Each xx In dicX.Items
        ii = ii + 1
        arr(ii) = Worksheets("ASSAY").ListObjects("Assay").Range.Columns(xx)
    Next
    
    GetArrASSAYColumns = arr
End Function


Private Function GetDicX() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim arr As Variant
    Dim xx As Long
    Dim ric As Object
    Set ric = CreateObject("Scripting.Dictionary")
    arr = Worksheets("RSA").ListObjects("йцу").HeaderRowRange
    For xx = 1 To UBound(arr, 2)
        ric.Item(arr(1, xx)) = 0
    Next
    
    arr = Worksheets("ASSAY").ListObjects("Assay").HeaderRowRange
    For xx = 1 To UBound(arr, 2)
        If ric.Exists(arr(1, xx)) Then dic.Item(arr(1, xx)) = xx
    Next
    
    Set GetDicX = dic
End Function
 
 
 
Страницы: 1
Наверх