Ir ao conteúdo
Regras do Clube do Hardware

Excel Loop pra transferir valor de sábado para o dia anterior ou posterior

Scofieldgyn

Por Scofieldgyn
em Microsoft Office e similares

 Compartilhar
Ir à solução Resolvido por Midori,

Posts recomendados

Midori
 

Midori

Postado
Postado

@Scofieldgyn Além da macro modifiquei a fórmula,

 

=SE(DIA.DA.SEMANA(I2)>=7;SE(OU(MÊS(I2)<>MÊS(I1);A2<>A1);"SD-1";"SD-2");"PRX")

 

Nos casos do último dia cair no sábado/domingo, usei a função Workday para pegar o próximo dia útil. Antes de rodar deixe a tabela em ordem.

  

Const FORMULA   As String = _
    "=IF(WEEKDAY(RC[-12])>=7,IF(OR(MONTH(RC[-12])<>" & _
    "MONTH(R[-1]C[-12]),RC[-20]<>R[-1]C[-20]),""SD-1"",""SD-2""),""PRX"")"
 
Const SD        As String = "SD-"
Const PRX       As String = "PRX"
Const COL_SKU   As Integer = 1
Const COL_DAT   As Integer = 9
Const COL_QTD   As Integer = 10
Const COL_VOL   As Integer = 11
Const COL_PROC  As Integer = 21

Sub Atualiza()
    Call ProcuraSD([A1].CurrentRegion)
End Sub

Sub ProcuraSD(Tabela As Range)
    Dim ProcSD          As Range
    Dim ProcPRX         As Range
    Dim ProcSKU         As Range
    Dim RngData         As Range
    Dim RngVol          As Range
    Dim RngQtd          As Range
    Dim UltData         As Date
    Dim ContaDataSku    As Long
    Dim TotalQtd        As Long
    Dim TotalVol        As Single
    Dim VarSD           As Variant
    Dim CodSku          As String
    Dim Direcao         As XlSearchDirection
    
    Do
        Set ProcSD = Tabela.Columns(COL_PROC).Find( _
            What:=SD, LookIn:=xlValues, LookAt:=xlPart)
    
        If Not ProcSD Is Nothing Then
            VarSD = Split(ProcSD.Value, "-")
            CodSku = ProcSD(, -(COL_PROC - COL_SKU - 1)).Value
            Set RngData = ProcSD(, -(COL_PROC - COL_DAT - 1))
            
            ContaDataSku = WorksheetFunction.CountIfs( _
                Tabela.Columns(COL_DAT), RngData.Value, Tabela.Columns(COL_SKU), CodSku)
            
            UltData = WorksheetFunction.MaxIfs( _
                Tabela.Columns(COL_DAT), Tabela.Columns(COL_SKU), CodSku)
        
            TotalQtd = WorksheetFunction.SumIfs( _
                Tabela.Columns(COL_QTD), _
                Tabela.Columns(COL_DAT), RngData.Value, Tabela.Columns(COL_SKU), CodSku)
        
            TotalVol = WorksheetFunction.SumIfs( _
                Tabela.Columns(COL_VOL), _
                Tabela.Columns(COL_DAT), RngData.Value, Tabela.Columns(COL_SKU), CodSku)
            
            If UBound(VarSD) = 1 Then
                Direcao = IIf(VarSD(1) = 1, xlNext, xlPrevious)
                
                Set ProcPRX = Tabela.Columns(COL_PROC).Find( _
                    What:=PRX, _
                    After:=ProcSD, _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchDirection:=Direcao)
                
                Set RngVol = ProcPRX(, -(COL_PROC - COL_VOL - 1))
                Set RngQtd = ProcPRX(, -(COL_PROC - COL_QTD - 1))
                
                If Direcao = xlNext Then
                    If UltData = RngData.Value Then
                        RngData.Resize(ContaDataSku).Value = _
                            WorksheetFunction.WorkDay(RngData.Value, 1)
                    Else
                        RngVol.Value = RngVol.Value + TotalVol
                        RngQtd.Value = RngQtd.Value + TotalQtd
                        ProcSD.Resize(ProcPRX.Row - ProcSD.Row).EntireRow.Delete
                        ProcPRX.Formula2R1C1 = FORMULA
                    End If
                Else
                    RngVol.Value = RngVol.Value + TotalVol
                    RngQtd.Value = RngQtd.Value + TotalQtd
                    ProcSD.EntireRow.Delete
                    ProcPRX(2).Formula2R1C1 = FORMULA
                End If
            End If
        End If
    Loop Until ProcSD Is Nothing
End Sub

 

OreiaG
 

OreiaG

Postado
Postado
Em 18/01/2023 às 11:23, Scofieldgyn disse:

 ... pois a quantidade de linhas é gigantesca, podendo ultrapassar mais de 600.00

 

Se você quiser testar esta opção.

Eu gostaria de saber sobre o desempenho deste código ao tratar as 600+ linhas.

 

Pode aplicar nos dados brutos, não é necessário ordenar, o código irá ordenar por sku/data.


  

Sub TrataVolumes()
 Dim r As Range, rng As Range, UL As Long, k As Long, v As Double
 Dim dat(), dict As Object, y As Long, x, LR As Long, z As Double
  Application.ScreenUpdating = False
  On Error Resume Next
  ActiveSheet.ShowAllData
  On Error GoTo 0
  [U:U] = ""
  UL = Cells(Rows.Count, 1).End(3).Row
  Range("A2:T" & UL).Sort Key1:=[A2], order1:=xlAscending, Key2:=[I2], order2:=xlAscending
  Set dict = CreateObject("Scripting.Dictionary")
  dat = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value2
  For y = 1 To UBound(dat)
    dict(dat(y, 1)) = Empty
  Next y
  With Range("U2:U" & UL)
   .Formula = "=IF(AND(DAY(I2)=1,WEEKDAY(I2)=7),""sáb1"",IF(WEEKDAY(I2,2)>5,""fds"",IF(AND(I3<>"""",WEEKDAY(I3,2)>5),1,"""")))"
   .Value = .Value
   For Each x In dict.keys
    ActiveSheet.[A1:T1].AutoFilter 1, x
    Set rng = ActiveSheet.AutoFilter.Range.Columns(21).SpecialCells(12)
    LR = Cells(Rows.Count, 20).End(3).Row
    For Each r In rng.SpecialCells(2, 1)
     Do While r.Row <= LR And r.Offset(k + 1) <> ""
      v = v + r.Offset(k + 1, -10): z = z + r.Offset(k + 1, -11)
      k = k + 1
     Loop
     If r.Offset(1) = "fds" Then
      r.Offset(, -10) = r.Offset(, -10) + v
      r.Offset(, -11) = r.Offset(, -11) + z
     Else: r.Offset(k + 1, -10) = r.Offset(k + 1, -10) + v
      r.Offset(k + 1, -11) = r.Offset(k + 1, -11) + z
     End If
     v = 0: z = 0
     Rows(r.Row + 1).Resize(k).Delete
     k = 0
    Next r
   Next x
  End With
  ActiveSheet.ShowAllData
  [U:U] = ""
End Sub

 

  • Obrigado 1
Scofieldgyn
 

Scofieldgyn

Postado
  • Autor
Postado

@Midori bom dia,

 

deu erro nessa linha.

 

image.png.d0549f75b52465ce49b27500643df97a.png

@OreiaG

Obrigado por você também compartilhar seu conhecimento e disponibilidade.

 

Testei seu código na planilha teste minha, a princípio ele executou corretamenbte apenas para um sku, isso quando o volume cai no sábado sendo o dia primeiro, ele somou corretamente. Mas não deu certo quando o sábado cai nos outros dias.

 

Outro ponto é que não deu certo nenhum quando vai para o próximo sku.

 

Estou colocando a planilha teste em anexo pra você ter uma ideia do que estou falando. Quando finalizarmos a validação, ai testarei na base completa pra poder te falar como será a perfomance do seu código.

Loop pra transferir Volume de Sábado para Sexta.zip

Midori
 

Midori

Postado
Postado
1 hora atrás, Scofieldgyn disse:

deu erro nessa linha.

 

Qual foi a mensagem de erro?

 

Talvez seja por causa da sua versão do Excel.

 

No seu tem a fórmula MÁXIMOSES?

Midori
 

Midori

Postado
Postado

@Scofieldgyn Editei essa linha para ficar compatível. Não precisa ordenar e editar a fórmula na planilha, a sub Atualiza já faz isso.

  

Const FORMULA   As String = _
    "=IF(WEEKDAY(RC[-12])>=7,IF(OR(MONTH(RC[-12])<>" & _
    "MONTH(R[-1]C[-12]),RC[-20]<>R[-1]C[-20]),""SD-1"",""SD-2""),""PRX"")"
 
Const SD        As String = "SD-"
Const PRX       As String = "PRX"
Const COL_SKU   As Integer = 1
Const COL_DAT   As Integer = 9
Const COL_QTD   As Integer = 10
Const COL_VOL   As Integer = 11
Const COL_PROC  As Integer = 21

Sub Atualiza()
    Dim Tabela As Range
    
    Set Tabela = [A1].CurrentRegion
    
    Call Tabela.Offset(1).Sort(Key1:=Tabela(2, COL_SKU), Key2:=Tabela(2, COL_DAT))
    Tabela(2, COL_PROC).Resize(Tabela.Rows.Count - 1).FormulaR1C1 = FORMULA
    
    Call ProcuraSD(Tabela)
End Sub

Sub ProcuraSD(Tabela As Range)
    Dim ProcSD          As Range
    Dim ProcPRX         As Range
    Dim ProcSKU         As Range
    Dim RngData         As Range
    Dim RngVol          As Range
    Dim RngQtd          As Range
    Dim UltData         As Date
    Dim ContaDataSku    As Long
    Dim TotalQtd        As Long
    Dim TotalVol        As Single
    Dim VarSD           As Variant
    Dim CodSku          As String
    Dim Direcao         As XlSearchDirection
    
    Do
        Set ProcSD = Tabela.Columns(COL_PROC).Find( _
            What:=SD, LookIn:=xlValues, LookAt:=xlPart)
    
        If Not ProcSD Is Nothing Then
            VarSD = Split(ProcSD.Value, "-")
            CodSku = ProcSD(, -(COL_PROC - COL_SKU - 1)).Value
            Set RngData = ProcSD(, -(COL_PROC - COL_DAT - 1))
            
            ContaDataSku = WorksheetFunction.CountIfs( _
                Tabela.Columns(COL_DAT), RngData.Value, Tabela.Columns(COL_SKU), CodSku)
            
            UltData = Evaluate("MAX(IF(" & _
                "'" & Tabela.Worksheet.Name & "'!" & _
                Tabela.Columns(COL_SKU).Address & "=" & CodSku & "," & _
                "'" & Tabela.Worksheet.Name & "'!" & _
                Tabela.Columns(COL_DAT).Address & "))")
                
            TotalQtd = WorksheetFunction.SumIfs( _
                Tabela.Columns(COL_QTD), _
                Tabela.Columns(COL_DAT), RngData.Value, Tabela.Columns(COL_SKU), CodSku)
        
            TotalVol = WorksheetFunction.SumIfs( _
                Tabela.Columns(COL_VOL), _
                Tabela.Columns(COL_DAT), RngData.Value, Tabela.Columns(COL_SKU), CodSku)
            
            If UBound(VarSD) = 1 Then
                Direcao = IIf(VarSD(1) = 1, xlNext, xlPrevious)
                
                Set ProcPRX = Tabela.Columns(COL_PROC).Find( _
                    What:=PRX, _
                    After:=ProcSD, _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchDirection:=Direcao)
                
                If Not ProcPRX Is Nothing Then
                    Set RngVol = ProcPRX(, -(COL_PROC - COL_VOL - 1))
                    Set RngQtd = ProcPRX(, -(COL_PROC - COL_QTD - 1))
                
                    If Direcao = xlNext Then
                        If UltData = RngData.Value Then
                            RngData.Resize(ContaDataSku).Value = _
                                WorksheetFunction.WorkDay(RngData.Value, 1)
                        Else
                            RngVol.Value = RngVol.Value + TotalVol
                            RngQtd.Value = RngQtd.Value + TotalQtd
                            ProcSD.Resize(ProcPRX.Row - ProcSD.Row).EntireRow.Delete
                            ProcPRX.Formula2R1C1 = FORMULA
                        End If
                    Else
                        RngVol.Value = RngVol.Value + TotalVol
                        RngQtd.Value = RngQtd.Value + TotalQtd
                        ProcSD.EntireRow.Delete
                        ProcPRX(2).Formula2R1C1 = FORMULA
                    End If
                End If
            End If
        End If
    Loop Until ProcSD Is Nothing
End Sub

 

Scofieldgyn
 

Scofieldgyn

Postado
  • Autor
Postado

@Midori

A fórmula fica ok, não dá erro nela propriamente.

 

Pode pegar essa ultima que anexei.

 

2 horas atrás, Scofieldgyn disse:

@Midori bom dia,

 

deu erro nessa linha.

 

image.png.d0549f75b52465ce49b27500643df97a.png

@OreiaG

Obrigado por você também compartilhar seu conhecimento e disponibilidade.

 

Testei seu código na planilha teste minha, a princípio ele executou corretamenbte apenas para um sku, isso quando o volume cai no sábado sendo o dia primeiro, ele somou corretamente. Mas não deu certo quando o sábado cai nos outros dias.

 

Outro ponto é que não deu certo nenhum quando vai para o próximo sku.

 

Estou colocando a planilha teste em anexo pra você ter uma ideia do que estou falando. Quando finalizarmos a validação, ai testarei na base completa pra poder te falar como será a perfomance do seu código.

Loop pra transferir Volume de Sábado para Sexta.zip 34 kB · 3 downloads

 

Midori
 

Midori

Postado
Postado

@Scofieldgyn Aqui não aconteceu nenhum erro. Tenta substituir a atribuição da fórmula nas duas linhas.

 

Onde está assim, 

ProcPRX.Formula2R1C1 = FORMULA
...
ProcPRX(2).Formula2R1C1 = FORMULA

 

Deve ficar, 

Tabela(2, COL_PROC).Resize(Tabela.Rows.Count - 1).FormulaR1C1 = FORMULA

 

  • Amei 1
Scofieldgyn
 

Scofieldgyn

Postado
  • Autor
Postado

@Midori

 

Deu certo, executei em uma base com 89.070 linhas, tempo de processamento da macro foi em 1 minuto e 11 segundos, achei bem satisfatório pela complexidade da rotina.

 

Agradeço novamente pelo seu tempo e conhecimento prestado!

 

abç

  • Curtir 1
Midori
 

Midori

Postado
Postado

@Scofieldgyn Um detalhe que acabou passando. A fórmula não está pegando domingo e pode retornar #VALUE caso a primeira data da tabela seja sábado ou domingo. Esta é a correção,

  

Const FORMULA As String = _
    "=IF(OR(WEEKDAY(RC[-12])=7,WEEKDAY(RC[-12])=1)," & _
    "IFERROR(IF(OR(MONTH(RC[-12])<>MONTH(" & _
    "R[-1]C[-12]),RC[-20]<>R[-1]C[-20]),""SD-1"",""SD-2""),""SD-1""),""PRX"")"

 

Scofieldgyn
 

Scofieldgyn

Postado
  • Autor
Postado

@Midori

 

Por ter raras ocorrências no Domingo, passou despercebido por mim. Alterei a fórmula e mandei rodar com um exemplo de sábado + domingo, o loop somou os dois e agregou com o de sexta com sucesso.

 

🙃😊🚀👏

 

Obrigado pela ajuda.

OreiaG
 

OreiaG

Postado
Postado
12 horas atrás, Scofieldgyn disse:

 

@OreiaG

 

Mas não deu certo quando o sábado cai nos outros dias.

Outro ponto é que não deu certo nenhum quando vai para o próximo sku.

Estou colocando a planilha teste em anexo pra você ter uma ideia do que estou falando.

 

Eu constatei os erros que você apontou. Eles ocorrem porque eu escrevi o código para o primeiro arquivo que você postou, e neste último que você anexou existem situações não previstas no primeiro.

 

Fiz os ajustes para processar o arquivo mais recente. Por favor veja se os resultados estão corretos.

Abaixo segue uma imagem com os dados antes e depois de rodar o código. As diferenças na numeração das linhas do "antes" para o "depois" é por conta da exclusão das linhas, que passam de 31 para 22 linhas com dados após rodar o código.

image.png.aaf529d502b26cea1feee1de7d7d0a9b.png

  

Sub TrataVolumesV2()
 Dim r As Range, rng As Range, UL As Long, k As Long, v As Double
 Dim dat(), dict As Object, y As Long, x, LR As Long, z As Double
  Application.ScreenUpdating = False
  On Error Resume Next
  ActiveSheet.ShowAllData
  On Error GoTo 0
  [U:U] = ""
  UL = Cells(Rows.Count, 1).End(3).Row
  Range("A2:U" & UL).Sort Key1:=[A2], order1:=xlAscending, Key2:=[I2], order2:=xlAscending
  Set dict = CreateObject("Scripting.Dictionary")
  dat = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value2
  For y = 1 To UBound(dat)
   dict(dat(y, 1)) = Empty
  Next y
  With Range("U2:U" & UL)
   .FORMULA = "=IF(AND(DAY(I2)=1,WEEKDAY(I2)=7),""sáb1"",IF(WEEKDAY(I2,2)>5,""fds"",IF(AND(I3<>"""",WEEKDAY(I3,2)>5),1,"""")))"
   .Value = .Value
   For Each x In dict.keys
    ActiveSheet.[A1:U1].AutoFilter 1, x
    Set rng = ActiveSheet.AutoFilter.Range.Columns(21).SpecialCells(12)
    LR = Cells(Rows.Count, 20).End(3).Row
    For Each r In rng.SpecialCells(2, 1)
     Do While r.Row <= LR And r.Offset(k + 1) <> "" And Application.IsText(r.Offset(k + 1))
      v = v + r.Offset(k + 1, -10): z = z + r.Offset(k + 1, -11)
      k = k + 1
     Loop
     If r.Offset(1) = "fds" Then
      r.Offset(, -10) = r.Offset(, -10) + v
      r.Offset(, -11) = r.Offset(, -11) + z
     Else: r.Offset(k + 1, -10) = r.Offset(k + 1, -10) + v
      r.Offset(k + 1, -11) = r.Offset(k + 1, -11) + z
     End If
     v = 0: z = 0
     Rows(r.Row + 1).Resize(k).Delete
     k = 0
    Next r
   Next x
  End With
  ActiveSheet.ShowAllData
  [U:U] = ""
End Sub

 

Scofieldgyn
 

Scofieldgyn

Postado
  • Autor
Postado

@OreiaG Realmente a primeira planilha estava com os exemplos fora do contexto.

 

Testei seu código na planilha exemplo e rodou  com sucesso sem erro, fez os cálculos esperado, porém quando fui testar na base completa de 89.070 linhas, apareceu esse erro abaixo:

 

image.png.9e70d3eed33f07a1b1c2164a8efe05c7.png

OreiaG
 

OreiaG

Postado
Postado

Hummm ... possivelmente algum SKU não tem data em final de semana. Essa situação não foi prevista.

Para evitar o erro, por favor, acrescente as duas linhas em vermelho conforme abaixo.

 

LR = Cells(Rows.Count, 20).End(3).Row
On Error GoTo nxtk
For Each r In rng.SpecialCells(2, 1)

 

e

 

    Next r
nxtk:   On Error GoTo -1
   Next x

OreiaG
 

OreiaG

Postado
Postado

É improvável o Loop sem fim.

 

Você experimentou deixar processar?

 

Às vezes o Excel mostra Não está respondendo, mas ele continua processando até encerrar a execução.

 

Se possível anexe o arquivo para testarmos.

Crie uma conta ou entre para comentar

Você precisa ser um usuário para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora
 Compartilhar
Ir à lista de tópicos

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

Mais

×
×
  • Criar novo...

LANÇAMENTO!

eletronica2025-popup.jpg


CLIQUE AQUI E BAIXE AGORA MESMO!