fbveiga

Boa tarde, Estou montando uma planilha onde necessito que ele verifique diversos cenarios e me retorne os valores que extrapolam um criterio. Em anexo segue a planilha com os codigos VBA, os quais nao acredito que sejam o ideal mas no momento foi o que eu pensei. Estou aberto a alterações. Abaixo seguem os códigos. O primeiro verifica onde a planilha foi alterada, verifica o valor se é numerico e coloca nas operações indicadas. Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Application.DisplayAlerts = False Dim estrutura As Worksheet acumulo = 0 stretch = 0 n = 1 ret = 0 a = 17 Set m = Target Set estrutura = Worksheets("Estrutura") '2016 If Target.Address = "$Microsoft8" Then If IsNumeric(Target) Then With estrutura While n <= .Cells(8, 10).Value stretch = stretch + .Cells(a, 8).Value If Target = 0 Then .Cells(a, 9).Value = 0 n = n + 1 a = a + 1 Else If m = 0 Then .Cells(a, 9) = 0 n = n + 1 a = a + 1 Else If Target > stretch Then If m > .Cells(a, 7).Value Then .Cells(a, 9) = .Cells(a, 8).Value ret = .Cells(a, 9) m = m - .Cells(a, 9).Value .Cells(a, 9) = ret * .Cells(a, 10).Value n = n + 1 a = a + 1 Else If m < .Cells(a, 8).Value Then .Cells(a, 9) = .Cells(a, 8).Value - m ret = .Cells(a, 8).Value - m m = m - .Cells(a, 9).Value .Cells(a, 9) = ret * .Cells(a, 10).Value n = n + 1 a = a + 1 Else .Cells(a, 9) = .Cells(a, 8).Value ret = .Cells(a, 8).Value m = m - .Cells(a, 9).Value .Cells(a, 9) = ret * .Cells(a, 10).Value n = n + 1 a = a + 1 End If End If Else .Cells(a, 9) = m ret = m m = m - .Cells(a, 9).Value .Cells(a, 9) = ret * .Cells(a, 10).Value n = n + 1 a = a + 1 End If End If End If Wend End With End If End If '---------------------------------------------------------------------------------------- '2017 stretch = 0 n = 1 ret = 0 y = 0 acumulo = 0 acumulob = 0 b = 33 Set m = Target If Target.Address = "$Microsoft9" Then If IsNumeric(Target) Then With estrutura acumulo = .Cells(8, 13).Value y = .Cells(8, 13).Value acumulob = .Cells(8, 13).Value + .Cells(9, 13).Value While n <= .Cells(9, 10).Value stretch = stretch + .Cells(b, 8).Value If Target = 0 Then .Cells(b, 9).Value = 0 n = n + 1 b = b + 1 Else If m = 0 Then .Cells(b, 9) = 0 n = n + 1 b = b + 1 Else If acumulo > stretch Then .Cells(b, 9) = 0 n = n + 1 b = b + 1 Else If acumulob < stretch Then .Cells(b, 9) = m ret = m m = m - .Cells(b, 9).Value .Cells(b, 9) = ret * .Cells(b, 10).Value n = n + 1 b = b + 1 Else If y > 0 Then .Cells(b, 9) = stretch - y ret = stretch - y m = m - .Cells(b, 9).Value y = 0 .Cells(b, 9) = ret * .Cells(b, 10).Value n = n + 1 b = b + 1 Else If Target > stretch Then If m > .Cells(b, 7).Value Then .Cells(b, 9) = .Cells(b, 8).Value ret = .Cells(b, 8).Value m = m - .Cells(b, 9).Value .Cells(b, 9) = ret * .Cells(b, 10).Value n = n + 1 b = b + 1 Else If m = .Cells(b, 7).Value Then .Cells(b, 9) = .Cells(b, 8).Value ret = .Cells(b, 8).Value m = m - .Cells(b, 9).Value .Cells(b, 9) = ret * .Cells(b, 10).Value n = n + 1 b = b + 1 Else If m > .Cells(b, 8).Value Then .Cells(b, 9) = .Cells(b, 8).Value ret = .Cells(b, 8).Value m = m - .Cells(b, 9).Value .Cells(b, 9) = ret * .Cells(b, 10).Value n = n + 1 b = b + 1 Else .Cells(b, 9) = .Cells(b, 8).Value - m ret = .Cells(b, 8).Value - m m = m - .Cells(b, 9).Value .Cells(b, 9) = ret * .Cells(b, 10).Value n = n + 1 b = b + 1 End If End If End If Else If m > .Cells(b, 8).Value Then .Cells(b, 9) = .Cells(b, 8).Value m = m - .Cells(b, 9).Value .Cells(b, 9) = .Cells(b, 8).Value * .Cells(b, 10).Value n = n + 1 b = b + 1 Else If m = .Cells(b, 8) Then .Cells(b, 9) = .Cells(b, 8).Value ret = .Cells(b, 8).Value m = m - .Cells(b, 9).Value .Cells(b, 9) = ret * .Cells(b, 10).Value n = n + 1 b = b + 1 Else .Cells(b, 9) = .Cells(b, 8).Value - m ret = .Cells(b, 8).Value - m m = m - .Cells(b, 9).Value .Cells(b, 9) = ret * .Cells(b, 10).Value n = n + 1 b = b + 1 End If End If End If End If End If End If End If End If Wend End With End If End If '---------------------------------------------------------------------------------------- '2018 stretch = 0 n = 1 ret = 0 acumulo = 0 y = 0 acumuloc = 0 c = 49 Set m = Target If Target.Address = "$Microsoft10" Then If IsNumeric(Target) Then With estrutura acumulo = .Cells(8, 13).Value + .Cells(9, 13).Value y = .Cells(8, 13).Value + .Cells(9, 13).Value acumuloc = .Cells(8, 13).Value + .Cells(9, 13).Value + .Cells(10, 13).Value While n <= .Cells(10, 10).Value stretch = stretch + .Cells(c, 8).Value If Target = 0 Then .Cells(c, 9).Value = 0 n = n + 1 c = c + 1 Else If m = 0 Then .Cells(c, 9) = 0 n = n + 1 c = c + 1 Else If acumulo > stretch Then .Cells(c, 9) = 0 n = n + 1 c = c + 1 Else If acumuloc < stretch Then .Cells(c, 9) = m ret = m m = m - .Cells(c, 9).Value .Cells(c, 9) = ret * .Cells(c, 10).Value n = n + 1 c = c + 1 Else If y > 0 Then .Cells(c, 9) = stretch - y ret = stretch - y m = m - .Cells(c, 9).Value y = 0 .Cells(c, 9) = ret * .Cells(c, 10).Value n = n + 1 c = c + 1 Else If Target > stretch Then If m > .Cells(c, 7).Value Then .Cells(c, 9) = .Cells(c, 8).Value ret = .Cells(c, 8).Value m = m - .Cells(c, 9).Value .Cells(c, 9) = ret * .Cells(c, 10).Value n = n + 1 c = c + 1 Else If m = .Cells(c, 7).Value Then .Cells(c, 9) = .Cells(c, 8).Value ret = .Cells(c, 8).Value m = m - .Cells(c, 9).Value .Cells(c, 9) = ret * .Cells(c, 10).Value n = n + 1 c = c + 1 Else If m > .Cells(c, 8).Value Then .Cells(c, 9) = .Cells(c, 8).Value ret = .Cells(c, 8).Value m = m - .Cells(c, 9).Value .Cells(c, 9) = ret * .Cells(c, 10).Value n = n + 1 c = c + 1 Else .Cells(c, 9) = .Cells(c, 8).Value - acumulo ret = .Cells(c, 8).Value - acumulo m = m - .Cells(c, 9).Value .Cells(c, 9) = ret * .Cells(c, 10).Value n = n + 1 c = c + 1 End If End If End If Else If m > .Cells(c, 8).Value Then .Cells(c, 9) = .Cells(c, 8).Value m = m - .Cells(c, 9).Value .Cells(c, 9) = .Cells(c, 8).Value * .Cells(c, 10).Value n = n + 1 c = c + 1 Else .Cells(c, 9) = m ret = m m = m - .Cells(c, 9).Value .Cells(c, 9) = ret * .Cells(c, 10).Value n = n + 1 c = c + 1 End If End If End If End If End If End If End If Wend End With End If End If '---------------------------------------------------------------------------------------- '2019 stretch = 0 n = 1 ret = 0 acumulo = 0 y = 0 acumulod = 0 d = 65 Set m = Target If Target.Address = "$Microsoft11" Then If IsNumeric(Target) Then With estrutura acumulo = .Cells(8, 13).Value + .Cells(9, 13).Value + .Cells(10, 13).Value y = .Cells(8, 13).Value + .Cells(9, 13).Value + .Cells(10, 13).Value acumulod = .Cells(8, 13).Value + .Cells(9, 13).Value + .Cells(10, 13).Value + .Cells(11, 13).Value While n <= .Cells(11, 10).Value stretch = stretch + .Cells(d, 8).Value If Target = 0 Then .Cells(d, 9).Value = 0 n = n + 1 d = d + 1 Else If m = 0 Then .Cells(d, 9) = 0 n = n + 1 d = d + 1 Else If acumulo > stretch Then .Cells(d, 9) = 0 n = n + 1 d = d + 1 Else If acumulod < stretch Then .Cells(d, 9) = m ret = m m = m - .Cells(d, 9).Value .Cells(d, 9) = ret * .Cells(d, 10).Value n = n + 1 d = d + 1 Else If y > 0 Then .Cells(d, 9) = stretch - y ret = stretch - y m = m - .Cells(d, 9).Value y = 0 .Cells(d, 9) = ret * .Cells(d, 10).Value n = n + 1 d = d + 1 Else If Target > stretch Then If m > .Cells(d, 7).Value Then .Cells(d, 9) = .Cells(d, 8).Value - acumulo ret = .Cells(d, 8).Value - acumulo m = m - .Cells(d, 9).Value .Cells(d, 9) = ret * .Cells(d, 10).Value n = n + 1 d = d + 1 Else If m = .Cells(d, 7).Value Then .Cells(d, 9) = .Cells(d, 8).Value ret = .Cells(d, 8).Value m = m - .Cells(d, 9).Value .Cells(d, 9) = ret * .Cells(d, 10).Value n = n + 1 d = d + 1 Else If m > .Cells(d, 8).Value Then .Cells(d, 9) = .Cells(d, 8).Value ret = .Cells(d, 8).Value m = m - .Cells(d, 9).Value .Cells(d, 9) = ret * .Cells(d, 10).Value n = n + 1 d = d + 1 Else .Cells(d, 9) = .Cells(d, 8).Value - acumulo ret = .Cells(d, 8).Value - acumulo m = m - .Cells(d, 9).Value .Cells(d, 9) = ret * .Cells(d, 10).Value n = n + 1 d = d + 1 End If End If End If Else If m > .Cells(d, 8).Value Then .Cells(d, 9) = .Cells(d, 8).Value m = m - .Cells(d, 9).Value .Cells(d, 9) = .Cells(d, 8).Value * .Cells(d, 10).Value n = n + 1 d = d + 1 Else .Cells(d, 9) = m ret = m m = m - .Cells(d, 9).Value .Cells(d, 9) = ret * .Cells(d, 10).Value n = n + 1 d = d + 1 End If End If End If End If End If End If End If Wend End With End If End If Application.ScreenUpdating = False Application.DisplayAlerts = False End Sub O segundo codigo que estou tentando criar, ele rodaria todos os cenarios possiveis que ultrapassem o valor de 100% e assim retorne esses valores em uma outra planilha. Sub inter() Application.ScreenUpdating = False Dim c As Long, i As Long, j As Long, h As Long a = 26 For c = 1 To 280000 For i = 1 To 450000 For j = 1 To 750000 For h = 1 To 1000000 Sheets("Estrutura").Range("M8").Value = c Sheets("Estrutura").Range("M9").Value = i Sheets("Estrutura").Range("M10").Value = j Sheets("Estrutura").Range("M11").Value = h If Sheets("Summary and Results").Range("D19").Value >= 1 Then Sheets("Summary and Results").Cells(a, 1).Value = c Sheets("Summary and Results").Cells(a, 2).Value = i Sheets("Summary and Results").Cells(a, 3).Value = j Sheets("Summary and Results").Cells(a, 4).Value = h a = a + 1 Else Next j Next i Next c Application.ScreenUpdating = False End Sub Agradeço desde já a ajuda e atenção de todos! PLANILHA