Страницы: 1
RSS
Динамика изменения цен на каждый товар, считывая цены с нескольких прайсов
 
вас сожрал антиспам повторите текст и файл-пример)
Не бойтесь совершенства. Вам его не достичь.
 
Mershik,
Подскажите, пожалуйста, в таком вопросе.
Есть прайс-лист в Excel с перечнем артикулов и цен. Через некоторое время в прайс вносятся изменения, а именно добавляются или удаляются позиции, и меняются цены (не всегда).
Задача:
Как сделать, чтобы Excel построил динамику изменения цен в абсолютном (руб.) и процентном соотношении на каждый товар, считывая цены с нескольких прайсов?
P.S. прайсы могу разместить в одной книге на разных листах
Изменено: marandi - 24.05.2020 22:41:22
 
marandi, в файле покажите исходные данные и желаемый результат как вы его видите на примера нескольких  (добавьте выше в #2)
Изменено: Mershik - 24.05.2020 21:41:11
Не бойтесь совершенства. Вам его не достичь.
 
Mershik,добавила документ "результат"
 
marandi, такой вариант правда нужно найти кок поиска числе как текст с нулями впереди позже гляну ил может кто-то  лучше предложит вариант
Код
Sub unik_count()
Dim cell As Range, rng As Range, art As Range, mes As Range
Dim sh As Worksheet
Dim col As New Collection
Dim x As Variant
Application.ScreenUpdating = False
Worksheets("Результат").Cells.Clear
On Error Resume Next
For Each sh In Worksheets
    If sh.Name <> "Результат" Then
        Set rng = sh.Range("A2:A" & sh.Cells(Rows.Count, 1).End(xlUp).Row)
        For Each cell In rng
            If Not IsEmpty(cell) Then col.Add cell.Value, CStr(cell.Value)
        Next cell
            lcol = Worksheets("Результат").Cells(1, Columns.Count).End(xlToLeft).Column + 1
            Worksheets("Результат").Cells(1, lcol) = sh.Name
    Else
        GoTo 1
    End If
1
Next sh
        For k = 1 To col.Count
            Worksheets("Результат").Cells(k + 1, 1) = col(k)
        Next k
For Each sh In Worksheets
    Set rng = sh.Range("A2:A" & sh.Cells(Rows.Count, 1).End(xlUp).Row)
        For Each cell In rng
        x = cell.Value
        Set art = Worksheets("Результат").Columns(1).Find(x, LookIn:=xlValues, LookAt:=xlWhole)
        Set mes = Worksheets("Результат").Rows(1).Find(sh.Name, LookIn:=xlValues, LookAt:=xlWhole)
            If Not art And mes Is Nothing Then
                Cells(art.Row, mes.Column) = cell.Offset(, 1).Value
            End If
        Next cell
Next sh
lcol2 = Cells(1, Columns.Count).End(xlToLeft).Column
lrow2 = Cells(Rows.Count, 1).End(xlUp).Row

For i = 3 To lcol2
    Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 1) = "абсолютное изменение в " & Cells(1, i) & " (руб.)"
    For n = 2 To lrow2
        Cells(n, Cells(1, Columns.Count).End(xlToLeft).Column) = Cells(n, i) - Cells(n, i - 1)
        Cells(n, Cells(1, Columns.Count).End(xlToLeft).Column).NumberFormat = "General"
    Next n
    
    Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 1) = "% изменение в " & Cells(1, i) & " (руб.)"
    For n = 2 To lrow2
        Cells(n, Cells(1, Columns.Count).End(xlToLeft).Column) = (Cells(n, i) - Cells(n, i - 1)) / Cells(n, i - 1)
        Cells(n, Cells(1, Columns.Count).End(xlToLeft).Column).NumberFormat = "0.00%"
    Next n
Next i
        With Rows(1)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
        With Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column)).Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
Application.ScreenUpdating = True
End Sub
Изменено: Mershik - 25.05.2020 10:18:00
Не бойтесь совершенства. Вам его не достичь.
 
Mershik,спасибо! Попробую
Страницы: 1
Наверх