Страницы: 1
RSS
VBA.Переписать размер скидки в базе после изменения скидок
 
Здравствуйте!
Прошу подсказать решение. Суть запроса, существует книга, на одном листе которой находится "база" продаж с перечислением типа товаров, группы и скидки, на втором листе находятся зависимые выпадающие списки с типами и группами товаров для заполнения вручную размера скидки по каждой позиции.
Необходимо при окончании заполнения размера скидок на одноименном листе, определить товар в базе и переписать  ее размер (не очистить базу и записать заново, а именно переписать).
Диапазоны на листе "скидка" в отличии от "базы" несмежные (именно как в примере).

Откликнувшимся заранее спасибо!
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 8 Then
        Dim s As String
        s = Rows(Target.Row).Range("F1").Value
        
        If s <> "" Then
            Dim y As Long
            On Error Resume Next
                y = WorksheetFunction.Match(s, Sheets("база").Columns("I:I"), 0)
            On Error GoTo 0
            If y > 0 Then
                Sheets("база").Columns("J:J").Cells(y, 1).Value = Target.Value
            End If
        End If
    End If
End Sub

В модуль листа "скидка".
Изменено: МатросНаЗебре - 02.04.2020 18:43:14
 
Спасибо, МатросНаЗебре, все работает!

Но подскажите, можно ли поправит код и привязать его к кнопке, чтобы вносить изменения по желанию (заполнил => нажал => внёс).
 
Можно и слегка поправить.
Код
Sub Discount()
    Dim a As Variant
    a = GetArr(Sheets("скидка").Range("F1"))
    Dim d As Object
    Set d = GetDic(a)
    FillPrice d
End Sub
'
Function GetArr(r As Range) As Variant
    With r.Parent
        Dim y As Long
        y = .Cells(.Rows.Count, r.Column).End(xlUp).Row
        Dim a As Variant
        a = .Range(.Cells(1, r.Column), .Cells(y, r.Column + 2))
    End With
    GetArr = a
End Function
'
Function GetDic(a As Variant) As Object
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 1 To UBound(a, 1)
        d.Item(a(y, 1)) = a(y, 3)
    Next
    Set GetDic = d
End Function
'
Sub FillPrice(d As Object)
    With Sheets("база")
        Dim a As Variant
        a = GetArr(.Range("I1"))
        Dim y As Long
        For y = 2 To UBound(a, 1)
            If d.Exists(a(y, 1)) Then
                .Columns("J:J").Cells(y, 1).Value = d.Item(a(y, 1))
            End If
        Next
    End With
End Sub
 
И второй макрос абсолютно рабочий, только подскажите последний момент - можно ли сделать вдруг незаполненные ячейки в "скидка" (пропуск ячейки), в базу вносились не пустые ячейки, а "0%" (нули).
Спасибо!
 
Замените функцию:
Код
Function GetDic(a As Variant) As Object
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 1 To UBound(a, 1)
        If IsEmpty(a(y, 3)) Then a(y, 3) = 0
        d.Item(a(y, 1)) = a(y, 3)
    Next
    Set GetDic = d
End Function
 
МатросНаЗебре, со всем уважением, огромное спасибо за труды!
 Буду разбираться в макросах Ваших для собственного понимания!
Страницы: 1
Наверх