Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Обновление прайса с помощью макроса
 
#1
29.04.2021 12:07:29
Добрый день,

Ребят кто поможет, есть данные с большим содержанием сделанный мною код долго думает. Можно как-то ускорить процесс? Может я вообще не то сделал?
Собрал так сказать такой код:
Код
Sub Result()

Dim rw As Long, wsB As Worksheet
        Set wsB = Worksheets("B")
        With Worksheets("A")
  
            For rw = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
                If CBool(Application.CountIf(wsB.Columns(1), .Cells(rw, 1).Value)) Then

                    ' INDEX/MATCH function pairs are used to wider scope
                    New_Price = Application.Index(wsB.Columns("D"), Application.Match(.Cells(rw, 1).Value, wsB.Columns("A"), 0))
                End If
            
            For Old_Price = 1 To .Cells(Rows.Count, 4).End(xlUp).Row
                If Old_Price <> New_Price Then
                    .Cells(rw, 4) = New_Price
                End If
            Next
        Next
    End With
End Sub
Спасибо!
 
 
 
#2
29.04.2021 12:10:14
MICHAIL NTOMOTSIDIS,
как вариант:
Код
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'ВАШ КОД

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
 
 
 
#3
29.04.2021 12:10:44
А можно словами описать задачу? Для оформления код есть специальный тег и кнопочка <...> на панельке, над текстом, который вы пишите сообщение.
Если есть уникальный ID, то можно воспользоваться функцией ВПР()
Изменено: New - 29.04.2021 12:17:04
 
 
 
#4
29.04.2021 12:17:25
Задача проста, Лист А содержит базу данных, лист В - работа со сканером штрих кодов, подтягивает текущие цены по совпадению ID (этого кода нет в примере), в процессе цены могут меняться в ручную на листе В, после завершения работы жмём на кнопку и текущие цены обновляются.  
 
 
 
#5
29.04.2021 12:20:38
Может так (через ВПР) ?

Код
    With Worksheets("A")
        With .Range("D2:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
            .FormulaLocal = "=ВПР(A2;B!A:D;4;0)"
            .Value = .Value
        End With
    End With
Изменено: New - 29.04.2021 12:22:34
 
 
 
#6
29.04.2021 13:30:40
evgeniygeo, как использовать предложенное?
с ВПР не подходит!
 
 
 
#7
29.04.2021 14:00:51
Код
Sub Result()
Dim arrA, arrB, oDict As Object, i As Long

    With Worksheets("A")
        arrA = .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    
    With Worksheets("B")
        arrB = .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.comparemode = 1
    
    For i = 2 To UBound(arrB, 1)
        If Not oDict.exists(arrB(i, 1)) Then oDict.Item(arrB(i, 1)) = arrB(i, 4)
    Next i
    
    For i = 2 To UBound(arrA, 1)
        If oDict.Item(arrA(i, 1)) <> arrA(i, 4) Then arrA(i, 4) = oDict.Item(arrA(i, 1))
    Next i
    
    With Worksheets("A")
        .Range("A1").Resize(UBound(arrA, 1), UBound(arrA, 2)).Value = arrA
    End With
    
End Sub
Изменено: New - 29.04.2021 14:07:48
 
 
 
#8
29.04.2021 14:03:07
Классно!! Спасибо!
 
 
 
#9
29.04.2021 14:07:21
Ничего классного нет... Лучше использовать ВПР )
Изменено: New - 29.04.2021 14:08:25
 
 
 
#10
29.04.2021 22:20:44
Почему?
Отлично работает! Спасибо.
 
 
 
#11
30.04.2021 00:01:53
Ой, только сейчас заметил, то что если список новых цен не полный( не все ID), то текущие (старые) цены, которые не обновлялись наш макрос удаляет!
это можно обойти?
 
 
 
#12
30.04.2021 05:12:40
Код
Sub UpdatePrice()
    Dim arrA, arrB, oDict As Object, i As Long
 
    With Worksheets("A")
        arrA = .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
     
    With Worksheets("B")
        arrB = .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
     
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.comparemode = 1
     
    For i = 2 To UBound(arrB, 1)
        If Not oDict.exists(arrB(i, 1)) Then oDict.Item(arrB(i, 1)) = arrB(i, 4)
    Next i
     
    For i = 2 To UBound(arrA, 1)
        If oDict.exists(arrA(i, 1)) Then
            If oDict.Item(arrA(i, 1)) <> arrA(i, 4) Then arrA(i, 4) = oDict.Item(arrA(i, 1))
        End If
    Next i
     
    With Worksheets("A")
        .Range("A1").Resize(UBound(arrA, 1), UBound(arrA, 2)).Value = arrA
    End With
        
    MsgBox "Цены обновлены!", vbInformation, "Конец"
End Sub
 
 
 
#13
30.04.2021 06:43:46
MICHAIL NTOMOTSIDIS,
не уверен, что сильно ускорит и лучше воспользоваться вариантом New
Код
Sub Result()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim rw As Long, wsB As Worksheet
        Set wsB = Worksheets("B")
        With Worksheets("A")
   
            For rw = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
                If CBool(Application.CountIf(wsB.Columns(1), .Cells(rw, 1).Value)) Then
 
                    ' INDEX/MATCH function pairs are used to wider scope
                    New_Price = Application.Index(wsB.Columns("D"), Application.Match(.Cells(rw, 1).Value, wsB.Columns("A"), 0))
                End If
             
            For Old_Price = 1 To .Cells(Rows.Count, 4).End(xlUp).Row
                If Old_Price <> New_Price Then
                    .Cells(rw, 4) = New_Price
                End If
            Next
        Next
    End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Изменено: evgeniygeo - 30.04.2021 06:45:18
 
 
 
Страницы: 1
Наверх