Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Определение процента при наличии общего количества материала на будущий год
 
#1
26.10.2023 14:27:11
Можно ли как-то осуществить макросом подсчёт процента от чисел ?
Допустим у меня есть количество купленных материалов за 2022 г, а мне необходимо подсчитать на 2024 г. в процентном соотношении. После чего количество материалов 2022 г. умножить на полученный процент, чтоб понять сколько материалов (шт.) заложить на 2024 г. Так как мне известно в какой лимит необходимо уложиться на 2024 г, мне от этой суммы лимита необходимо получить процент по отношению материалов 2022 г. по всем позициям, скорее всего определить это каким-то диапазоном ячеек в случае увеличения или уменьшения материалов.
 
 
 
#2
26.10.2023 14:40:18
однако)
в В31 =СУММ(B12:B30)
в С12 =ОКРУГЛ(B12*$C$31/$B$31;0)
тянете С12 вниз до С29
в С30 =C31-СУММ(C12:C29)
---------------------------
готово
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
27.10.2023 09:07:35
Это понятное дело, но мне нужно оттолкнуться не цепляясь от Итоговой суммы 2022 г.
Цитата
Ігор Гончаренко написал:
в В31 =СУММ(B12:B30)
Ну типа 66 000/120*100 и получается какой-то процент.
 
 
 
#4
27.10.2023 09:22:08
Цитата
Tatar написал:
66 000/120*100 и получается какой-то процент.
зачем же какой-то, получаются вполне конкретные 550%
Цитата
Tatar написал:
но мне нужно оттолкнуться не цепляясь от Итоговой суммы 2022 г
нужно - отталкивайтесь, от чего вам нужно, в чем был смысл первого сообщения как и всей этой темы
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#5
27.10.2023 11:26:09
Думал может есть возможность макросом подкрепить это всё.
 
 
 
#6
27.10.2023 11:53:48
Цитата
написал:
Думал может есть возможность макросом подкрепить это всё.
Вы бы в предыдущих двух сообщениях хоть намекнули бы о этом.
Код
Sub Podkrepit()
    Dim flag As Boolean
    Dim rr As Range
    Set rr = Selection
    If rr.Areas.Count <> 3 Then
        flag = False
    Else
        flag = True
    End If
    
    Dim arr As Variant
    Dim irr As Variant
    ReDim arr(1 To 3) As Range
    ReDim irr(1 To 3) As Byte
    
    If flag Then
        Dim ii As Long
        For ii = 1 To 3
            If rr.Areas(ii).Cells.CountLarge > 1 Then
                If WorksheetFunction.Count(rr.Areas(ii)) > 0 Then
                    Set arr(1) = rr.Areas(ii)
                    irr(1) = ii
                    Exit For
                End If
            End If
        Next
        If irr(1) = 0 Then
            MsgBox "Должно быть выделено 3 области." & vbCr & "Одна область должна быть более одной ячейки и содержать значения.", vbCritical
        Else
            For ii = 1 To 3
                Select Case ii
                Case irr(1)
                Case Else
                    If rr.Areas(ii).Value <> 0 Then
                        If WorksheetFunction.Count(rr.Areas(ii)) > 0 Then
                            Set arr(2) = rr.Areas(ii)
                            irr(2) = ii
                            Exit For
                        End If
                    End If
                End Select
            Next
        
            If irr(2) = 0 Then
                MsgBox "Должно быть выделено 3 области." & vbCr & "Одна область должна состоять из одной ячейки и содержать значение.", vbCritical
            Else
                For ii = 1 To 3
                    Select Case ii
                    Case irr(1), irr(2)
                    Case Else
                        Set arr(3) = rr.Areas(ii).Cells(1)
                        irr(3) = ii
                        Exit For
                    End Select
                Next
            End If
            
            If irr(3) = 0 Then
                MsgBox "Должно быть выделено 3 области.", vbCritical
            Else
                Dim vrr As Variant
                vrr = arr(1).Value
                
                Dim dsum1 As Double
                dsum1 = WorksheetFunction.Sum(arr(1).Value)
                
                If dsum1 = 0 Then
                    MsgBox "Сумма значений должна быть больше нуля.", vbCritical
                Else
                    Dim dsum2 As Double
                    dsum2 = arr(2).Value
                    
                    Dim ratio As Double
                    ratio = dsum2 / dsum1
                    
                    Dim orr As Variant
                    ReDim orr(1 To UBound(vrr, 1), 1 To 1) As Long
                    
                    Dim yy As Long
                    Dim dsum3 As Long
                    For yy = 1 To UBound(vrr, 1)
                        orr(yy, 1) = ratio * vrr(yy, 1)
                        dsum3 = dsum3 + orr(yy, 1)
                    Next
                    orr(UBound(vrr, 1), 1) = orr(UBound(vrr, 1), 1) + (dsum2 - dsum3)
                    
                    arr(3).Resize(UBound(orr, 1)).Value = orr
                End If
            End If
        End If
    End If
End Sub
Выделите 3 области, зажав Ctrl.
Область значений 2022.
Область значений 2024.
Сумму 2024.
Запустите макрос.
 
 
 
#7
30.10.2023 16:26:55
Выдаёт ошибку.
Изменено: Tatar - 30.10.2023 16:27:20
 
 
 
#8
30.10.2023 17:45:38
Код
Sub Podkrepit()
    Dim flag As Boolean
    Dim rr As Range
    Set rr = Selection
    If rr.Areas.Count <> 3 Then
        flag = False
    Else
        flag = True
    End If
    
    Dim arr As Variant
    Dim irr As Variant
    ReDim arr(1 To 3) As Range
    ReDim irr(1 To 3) As Byte
    
    If flag Then
        Dim ii As Long
        For ii = 1 To 3
            If rr.Areas(ii).Cells.CountLarge > 1 Then
                If WorksheetFunction.Count(rr.Areas(ii)) > 0 Then
                    Set arr(1) = rr.Areas(ii)
                    irr(1) = ii
                    Exit For
                End If
            End If
        Next
        If irr(1) = 0 Then
            MsgBox "Должно быть выделено 3 области." & vbCr & "Одна область должна быть более одной ячейки и содержать значения.", vbCritical
        Else
            For ii = 1 To 3
                Select Case ii
                Case irr(1)
                Case Else
                    If rr.Areas(ii).Cells.CountLarge = 1 Then
                        If rr.Areas(ii).Value <> 0 Then
                            If WorksheetFunction.Count(rr.Areas(ii)) > 0 Then
                                Set arr(2) = rr.Areas(ii)
                                irr(2) = ii
                                Exit For
                            End If
                        End If
                    End If
                End Select
            Next
        
            If irr(2) = 0 Then
                MsgBox "Должно быть выделено 3 области." & vbCr & "Одна область должна состоять из одной ячейки и содержать значение.", vbCritical
            Else
                For ii = 1 To 3
                    Select Case ii
                    Case irr(1), irr(2)
                    Case Else
                        Set arr(3) = rr.Areas(ii).Cells(1)
                        irr(3) = ii
                        Exit For
                    End Select
                Next
            End If
            
            If irr(3) = 0 Then
                MsgBox "Должно быть выделено 3 области.", vbCritical
            Else
                Dim vrr As Variant
                vrr = arr(1).Value
                
                Dim dsum1 As Double
                dsum1 = WorksheetFunction.Sum(arr(1).Value)
                
                If dsum1 = 0 Then
                    MsgBox "Сумма значений должна быть больше нуля.", vbCritical
                Else
                    Dim dsum2 As Double
                    dsum2 = arr(2).Value
                    
                    Dim ratio As Double
                    ratio = dsum2 / dsum1
                    
                    Dim orr As Variant
                    ReDim orr(1 To UBound(vrr, 1), 1 To 1) As Long
                    
                    Dim yy As Long
                    Dim dsum3 As Long
                    For yy = 1 To UBound(vrr, 1)
                        orr(yy, 1) = ratio * vrr(yy, 1)
                        dsum3 = dsum3 + orr(yy, 1)
                    Next
                    orr(UBound(vrr, 1), 1) = orr(UBound(vrr, 1), 1) + (dsum2 - dsum3)
                    
                    arr(3).Resize(UBound(orr, 1)).Value = orr
                End If
            End If
        End If
    End If
End Sub
 
 
 
#9
31.10.2023 08:13:11
МатросНаЗебре, Большое спасибо за Ваш труд и помощь.
 
 
 
Страницы: 1
Наверх