Este fórum está sendo desativado

[Leonardo1234]

Bom Dia Pessoal,

Eu gostaria de uma ajuda em uma macro que tenha a capacidade de modificar uma amostra de dados com base em percentuais correspondentes aos dados dessa amostra. Eu vou deixar em anexo a planilha para melhor entendimento. Eu tenho uma lista de 4 produtos, em que para cada um foi designado um código de identificação. Esses mesmos códigos preenchem uma amostra de 100 células. O que eu preciso é que a distribuição dos 4 códigos dos produtos na amostra de 100 células seja correspondente ao percentual de participação de cada código na amostra. Na minha planilha, eu já deixei a distribuição dos códigos conforme os percentuais escolhidos, o que eu preciso é que ao alterar os percentuais, a amostra corrija a distribuição dos códigos automaticamente. Obrigado.

[osvaldomp]

Experimente:

Código: Selecionar todos

Sub DistribuiConfPercentual()
 Dim c As Range
  [I2:I101] = ""
  For Each c In [C3:C6]
   Cells(Rows.Count, 9).End(3)(2).Resize(c.Offset(, 1).Value * 100).Value = c.Value
  Next c
End Sub

[babdallas]

Código: Selecionar todos

Option Explicit

Public Sub DistribuirProdutos()
    Dim vrtPercentual       As Variant
    Dim vrtCod              As Variant
    Dim vrtCodF(1 To 100)   As Variant
    Dim lobTabela           As ListObject
    Dim lngCont             As Long
    Dim dblPerc             As Double
    Dim lngPos              As Long
    Dim dblQtd              As Double
    
    Set lobTabela = Planilha1.ListObjects("tbDistr")
    
    vrtCod = lobTabela.ListColumns("Código").DataBodyRange.Value2
    vrtPercentual = lobTabela.ListColumns("Percentual").DataBodyRange.Value2
    
    For lngCont = LBound(vrtPercentual, 1) To UBound(vrtPercentual, 1)
        dblPerc = dblPerc + vrtPercentual(lngCont, 1)
    Next lngCont
    
    If dblPerc <> 1 Then
        VBA.MsgBox Prompt:="Os percentuais dos produtos não somam 100%." _
                            & VBA.Chr(10) & _
                            "Corrija e rode a macro novamente"
        Exit Sub
    End If
    Planilha1.Range("I2:I101").ClearContents
    
    lngPos = 1
    dblQtd = vrtPercentual(lngPos, 1) * 100
    For lngCont = 1 To Planilha1.Range("nAmostra").Value2
        If dblQtd < lngCont Then
            lngPos = lngPos + 1
            dblQtd = dblQtd + vrtPercentual(lngPos, 1) * 100
        End If
        
        vrtCodF(lngCont) = vrtCod(lngPos, 1)
    Next lngCont
    
    Planilha1.Range("I2:I101").Value2 = Application.Transpose(vrtCodF)
End Sub