Código VBA com contadores a percorrerem direcções opostas

[FranciscoF 0]

Antes de mais, boa noite a todos os foristas.

Sou um recém utilizador de VBA e ainda estou a dar os meus 1ºs passos. Já tenho alguns conhecimentos de C e C++, que me permitem um raciocinio bom em pseudo-código, mas a parte da sintaxe ainda está mt pobre.

Conheci o fórum na internet pois era um link recorrente nas buscas que fiz para tirar dúvidas (muitas) que encontrei.

O objectivo do meu código é percorrer uma lista de várias colunas da data + recente para a mais antiga e reconhecer o valor 0101 numa coluna. Qd reconhece essa valor percorre a lista a partir dessa data no sentido da data + recente para identificar o nº de vezes o mesmo material e fornecedor voltam a aparecer.

Sub avalia_skip_v3()

Dim i As Integer
Dim j As Integer
Dim data_S0 As Date
Dim Row_inv As Integer
Dim Column_size As Long
Dim N1 As ListColumn
Dim N2 As ListColumn
Dim Row As Long
Dim Regra_Skip As Worksheet
Dim material As Double
Dim fornecedor As Double

Set Regra_Skip = Sheets.Add

j = 2

i = 2

'saber o tamanho da lista:

Column_size = Sheets("Sheet1").Range("A:A")

'Ciclo decrescente, em data, para encontrar código 0101 e qd encontra, passa toda a linha para a página criada

For Row = Column_size To i

If Cells(Row, "TpCtrl.").Value = "0101" Then

    ActiveCell.RowRange.Select
    Selection.Copy
    Sheets("Regra_Skip").Activate
    Sheets("Regra_Skip").Range.Row(j).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Selection.Clear
    
' cria coluna na nova folha para armazenar diferença entre datas

Sheets("Regra_Skip").ListColumns.Add = N1
N1.Name = "Data desde S0"

' executa a diferença entre datas

Cells(j, "Data desde S0") = DateDiff("ym", Now, Data fim)


' cria coluna na nova folha para armazenar contador de series normais

Sheets("Regra_Skip").ListColumns.Add = N2
N2.Name = "Nº Series Normal"

'guarda material e fornecedor para ler series 01 posteriores referentes a esses valores.
    
    material = Cells(Row, "Material")
    fornecedor = Cells(Row, "Fornecedor")
    
'faz contador para Serie 01
'Conta numero de series 01 desde a ocorrencia da Serie 0101 em direção às mais recentes

    For Row_inv = Row To Column_size
    
        If Cells(Row_inv, "Material") = material And Cells(Row_inv, "Fornecedor") = fornecedor Then
            If Not Cells(Row_inv, "Code DU") = “9” Then
                    Sheets("Regra_Skip").Cells(j, "Nº Series Normal").Value = Cells(j, "Nº Series Normal").Value + 1
                End If
            End If
        j = j + 1
    Next Row_inv
    End If
    
Next Row

End Sub

 

Este código é para aplicar na seguinte lista:

LotCtrl  Material  Texto breve do objeto de controle  Status do sistema  Skip  Fornecedor  TpCtrl.  Code DU  Qtd.lote  DtaInício  Data fim

010400781444  6-720-006-339  Esferovite inferior  DU  CNTC ESTD COIM ESAT      140646  01  1  96,000  06-08-2010  06-08-2010

010400782418  6-720-006-339  Esferovite inferior  DU  CNTC ESTD COIM ESAT      140646  01  1  192,000  09-08-2010  09-08-2010

010400831238  6-720-006-343  Caixa de cartao 473x769x268  DU  CNTC ESTD COIM ESAT      657793  0101  5  304,000  24-11-2010  24-11-2010

010400829969  6-720-006-344  Caixa de cartao 468x825x290  DU  CNTC ESTD COIM ESAT      657793  0101  5  320,000  22-11-2010  22-11-2010

010400814858  6-720-007-028  CAIXA DE CARTÃO  DU  CNTC ESTD COIM ESAT      657593  0101  5  3,000  22-10-2010  22-10-2010

010400827268  6-720-007-028  CAIXA DE CARTÃO  DU  CNTC ESTD COIM ESAT      657593  0101  1  250,000  17-11-2010  17-11-2010

010400840436  6-720-007-028  CAIXA DE CARTÃO  DU  CNTC ESTD COIM ESAT      657593  0101  1  3,000  14-12-2010  14-12-2010

010400813985  6-720-007-116  Caixa de Cartao  DU  CNTC ESTD COIM ESAT      657593  0101  1  250,000  21-10-2010  21-10-2010

010400814870  6-720-007-116  Caixa de Cartao  DU  CNTC ESTD COIM ESAT      657593  0101  1  3,000  22-10-2010  22-10-2010

010400793851  6-720-007-205  CAIXA DE CARTÃO  DU  CNTC ESTD COIM ESAT      657593  01  1  225,000  09-09-2010  09-09-2010

010400794393  6-720-007-205  CAIXA DE CARTÃO  DU  CNTC ESTD COIM ESAT      657593  01  1  135,000  10-09-2010  10-09-2010

010400781331  6-720-007-206  CAIXA DE CARTÃO  DU  CNTC ESTD COIM ESAT      657593  01  1  240,000  06-08-2010  06-08-2010

010400759725  6-720-007-221  PALETE 1200x1000 C/ TRAT. TERMICO  DU  CNTC ESTD COIM ESAT      657553  01  1  65,000  24-06-2010  24-06-2010

010400761030  6-720-007-221  PALETE 1200x1000 C/ TRAT. TERMICO  DU  CNTC ESTD COIM ESAT      657553  01  1  50,000  28-06-2010  28-06-2010

010400764097  6-720-007-221  PALETE 1200x1000 C/ TRAT. TERMICO  DU  CNTC ESTD COIM ESAT      657553  01  1  108,000  02-07-2010  02-07-2010

010400768680  6-720-007-221  PALETE 1200x1000 C/ TRAT. TERMICO  DU  CNTC ESTD COIM ESAT      657918  0101  9  10,000  12-07-2010  12-07-2010

010400824922  6-720-007-221  PALETE 1200x1000 C/ TRAT. TERMICO  DU  CNTC ESTD COIM ESAT      657918  0101  1  10,000  12-11-2010  12-11-2010

010400805955  6-720-007-233  Caixa de Cartao  600x400x340  DU  CNTC ESTD COIM ESAT      657793  01  1  400,000  04-10-2010  04-10-2010

010400803228  6-720-007-239  Caixa de Cartao 300x200x120  DU  CNTC ESTD COIM ESAT      657793  01  1  960,000  28-09-2010  28-09-2010

010400835347  6-720-007-241  Caixa de Cartao 400x300x220  DU  CNTC ESTD COIM ESAT      657793  01  1  320,000  03-12-2010  03-12-2010

010400762519  6-720-007-254  Caixa de Madeira 640x640x400  DU  CNTC ESTD COIM ESAT      657918  01  1  4,000  30-06-2010  30-06-2010

010400827976  6-720-007-269  Caixa de cartao  DU  CNTC ESTD COIM ESAT      657700  01  1  285,000  18-11-2010  18-11-2010

010400749693  6-720-007-271  Caixa Impressa Compact 16 L  DU  CNTC ESTD COIM ESAT      657593  0101  10  3,000  02-06-2010  02-06-2010

010400781370  6-720-007-271  Caixa Impressa Compact 16 L    DU  CNTC ESTD COIM ESAT      657593  0101  1  320,000  06-08-2010  06-08-2010

010400781860  6-720-007-271  Caixa Impressa Compact 16 L    DU  CNTC ESTD COIM ESAT      657593  0101  1  3,000  07-08-2010  07-08-2010

010400797403  6-720-007-271  Caixa Impressa Compact 16 L    DU  CNTC ESTD COIM ESAT      657593  01  1  320,000  16-09-2010  16-09-2010

010400749691  6-720-007-272  Caixa Impressa Compact 11 L    DU  CNTC ESTD COIM ESAT      657593  0101  10  3,000  02-06-2010  02-06-2010

010400781371  6-720-007-272  Caixa Impressa Compact 11 L    DU  CNTC ESTD COIM ESAT      657593  0101  1  312,000  06-08-2010  06-08-2010

010400781861  6-720-007-272  Caixa Impressa Compact 11 L    DU  CNTC ESTD COIM ESAT      657593  0101  1  3,000  07-08-2010  07-08-2010

010400813940  6-720-007-272  Caixa Impressa Compact 11 L      DU  CNTC ESTD COIM ESAT      657593  01  1  320,000  21-10-2010  21-10-2010

010400756057  6-720-007-273  Caixa de cartao 465x100x420  DU  CNTC ESTD COIM ESAT      657593  0101  1  255,000  17-06-2010  17-06-2010

010400757317  6-720-007-273  Caixa de cartao 465x100x420  DU  CNTC ESTD COIM ESAT      657593  0101  1  3,000  21-06-2010  21-06-2010

010400827260  6-720-007-273  Caixa de cartao 465x100x420  DU  CNTC ESTD COIM ESAT      657593  01  1  320,000  17-11-2010  17-11-2010

010400824269  6-720-074-047  Caixa de Cartao  DU  CNTC ESTD COIM ESAT      657593  0101  5  250,000  11-11-2010  11-11-2010

010400836826  6-720-074-047  Caixa de Cartao  DU  CNTC ESTD COIM ESAT      657593  0101  5  3,000  07-12-2010  07-12-2010

010400833941  6-720-150-301  FITA ADESIVA INTERMITENTE P/ESQ.  DU  CNTC ESTD COIM ESAT  X  655043  01  1  1.440,000  30-11-2010  30-11-2010

010400753751  6-720-370-009  Absorber fixation assembeld  DU  CNTC ESTD COIM ESAT      97077447  01  1  800,000  14-06-2010  14-06-2010

010400761897  6-720-370-009  Absorber fixation assembeld  DU  CNTC ESTD COIM ESAT      97077447  01  1  800,000  29-06-2010  29-06-2010

010400768808  6-720-370-009  Absorber fixation assembeld  DU  CNTC ESTD COIM ESAT      97077447  01  1  800,000  12-07-2010  12-07-2010

 

A depurar o código tenho um erro no 1º If e tenho dúvidas sobre a forma como me posso referir a colunas, no caso "TpCtrl." se o ponto existente no final atrapalha ou não.

Aguardo o vosso feedback e agradeço desde já a ajuda.

Cumps!

[jpaulino 90]

Olá,

Em primeiro lugar bem vindo à comunidade.

Relativamente à primeira utilização do If, está errada (como o compilado já te disse). O sintaxe é o seguinte:

If cells(linha, coluna).Value = critério Then

Podendo ser indicado na coluna um número (index) ou a coluna (letra).

Nesse caso deverá ser 8 ou "h".

If Cells(Row, "h").Value = "0101" Then
     ' código
End If

Isto aplica-se, obviamente, para as restantes utilizações no código.

[FranciscoF 0]

Obrigado Jpaulino pela óptima recepção!

Vou corrigir e ver como corre. O teu esclarecimento aponta para uma das minhas falhas de formação que já identifiquei, a dificuldade em fazer a ligação VBA - Excel.

Estou a ler um livro sobre Excel 2003 que é o que uso, de Jonh Walkenbach, mas tenho outros como o do MrExcel para o Excel 2010. Será boa prática estudar pelo livro do Excel 2010 quando estou a utilizar o Excel 2003?

A pergunta se calhar até é bastante ignorante, mas como te disse sou muito maçarico ainda em VBA.

Cumprimentos, Francisco.

[jpaulino 90]

Estou a ler um livro sobre Excel 2003 que é o que uso, de Jonh Walkenbach, mas tenho outros como o do MrExcel para o Excel 2010. Será boa prática estudar pelo livro do Excel 2010 quando estou a utilizar o Excel 2003?

A pergunta se calhar até é bastante ignorante, mas como te disse sou muito maçarico ainda em VBA.

A diferença é minima e não há problema algum. É melhor até aprender em versões posteriores (2007 e 2010) pois as versões são mais exigentes (segurança, versões dos ficheiros, etc).

Tenho dado formação para utilizadores de Excel 2003 em Excel 2010 e a adaptação é rápida.

[FranciscoF 0]

Olá bom dia!

Já corrigi o código mas penso que não avança a partir do 1º ciclo For.

Nem sequer executa o 1º IF.

O que faz é criar uma nova folha e indicar o tamanho da lista.

Será que o problema está no meu ciclo For? Como estou a implementar uma contagem decrescente, basta indicar no For inicial os valores iniciais e finais que apesar de ter next no final ele fará a contagem decrescente?

Outra pergunta, para não ser muito chato... ;-).

O meu código começa e acaba com a condição IF que está dentro do ciclo For, mas se a condição que indiquei para o If não se verificar, supostamente, o programa deve voltar a testar a condição IF, porque atinge o Next Row do final do código e por isso volta ao 1º If, certo?

Cumprimentos a todos

[jpaulino 90]

Tens alguns erros e não é facil enumerar todos ... é normal de inicio, mas vai com calma.

Isto deve dar-te um errro (ou zero)

Column_size = Sheets(1).Range("A:A")

Depois se queres em dias deves indicar "d" e não "ym" (que até acho que não funciona ... não testei). Além disso Data fim não é válido.

DateDiff("ym", Now, Data fim)

Mostra lá como tens o código agora e onde tens mais erros!

[FranciscoF 0]

Boa tarde, JPaulino!

Mais uma vez obrigado pela ajuda.

Já estou a avançar no programa, mas os erros abundam, é um facto.

Bom, isto está um bocado confuso, porque eu vou testando novas coisas e deixo as antigas como comentário, caso a coisa dê para o torto...

Estou a testar com um MsgBox em diferentes pontos para saber até onde está a ler o código.

Sobre o Datediff, tinha colocado "ym" porque queria que o resultado aparecesse em meses, e desde que coloquei o 1º For como comentário, porque não estava a avançar no ciclo, o erro tá aí.

Neste momento está assim:

Option Explicit


Sub avalia_skip_v3()

'Avalia_Skip gravada por utilizador FEF1AV a 19/01/2011

Dim i As Long
Dim j As Long
Dim data_S0 As Date
Dim Row_inv As Long
Dim Column_size As Variant
Dim N1 As ListColumn
Dim N2 As ListColumn
Dim Row As Long
Dim material As Double
Dim fornecedor As Double
Dim Regra_Skip As Worksheet, flg As Boolean

For Each Regra_Skip In Worksheets
If Regra_Skip.Name Like "Regra_Skip" Then flg = True: Exit For
Next
If flg = True Then
MsgBox "Found!"
Else
Sheets.Add.Name = "Regra_Skip"
End If


' Set Regra_Skip = Sheets.Add

' If Worksheets("Regra_Skip") = False Then
'   Worksheets.Add().Name = "Regra_Skip"
    
  '  End If

Sheets("Sheet1").Activate

' Rows("1").Copy Destination:=Sheets("Regra_Skip").Range("1")

j = 2

i = 2

'saber o tamanho da lista:

Column_size = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

'Ciclo decrescente, em data, para encontrar Series 0
  ' MsgBox "The count is " & Column_size

Row = Column_size

' For Row = Column_size To i


' If Cells(Row, "TpCtrl") = "0101" Then

' If Worksheets("Sheet1").Cells(Row, "TpCtrl").Value = "0101"

If Cells(Row, "F").Value = 101 Then

   ' MsgBox "The count is " & Column_size
   
   Rows(Row).Copy Destination:=Sheets("Regra_Skip").Range("A" & Rows.Count).End(xlUp).Offset(1)
    
    ' ActiveCell.RowRange.Select
    ' Selection.Copy
    ' Sheets("Regra_Skip").Activate
    ' Sheets("Regra_Skip").Range.Row(j).Select
    ' Selection.PasteSpecial Paste:=xlPasteValues
    ' Selection.Clear
    
' cria coluna na nova folha para armazenar diferença entre datas

Sheets("Regra_Skip").Columns("K:K").EntireColumn.Insert
Sheets("Regra_Skip").Cells(j, "K:K").Name = "Data_desde_S0"

' Sheets("Regra_Skip").ListColumns.Add = N1
' N1.Name = "Data desde S0"

' executa a diferença entre datas

Cells(j, "K:K") = DateDiff("ym", Now, "J:J")

' cria coluna na nova folha para armazenar contador de series normais

Sheets("Regra_Skip").ListColumns.Add = N2
N2.Name = "Nº Series Normal"

'guarda material e fornecedor para ler series normais posteriores referentes a esses valores.
    
    material = Cells(Row, "B")
    fornecedor = Cells(Row, "E")
    
'faz contador para Serie Normal
'Conta numero de series normais da data da Serie 0 para as mais recentes

    For Row_inv = Row To Column_size
    
        If Cells(Row_inv, "B") = material And Cells(Row_inv, "E") = fornecedor Then
            If Not Cells(Row_inv, "G") = "9" Then
                    Sheets("Regra_Skip").Cells(j, "Nº Series Normal").Value = Cells(j, "Nº Series Normal").Value + 1
                End If
            End If
        j = j + 1
    Next Row_inv
    
End If

Column_size = Column_size - 1

' Next Row

End Sub

O que me parece é que quando a 1ª linha que o programa lê (neste caso é a ultima da lista) não possui o valor 101 o código perde-se porque o If não é executado pois a condição é falsa e o For não funciona.

Obrigado pela ajuda, cumps.

[FranciscoF 0]

Bom, acho que o código já está a ficar muito confuso, e ainda falta um ciclo IF para verificar se não estou a repetir materiais e fornecedores na nova folha, por isso acho que o melhor é começar a fazer uma coisa limpa.

Já estou há algum tempo a tentar saber como funciona o DateDiff mas não está fácil...

E gostaria de poder fazer as referências às colunas pelo seu nome e não pela letra, mas se não puder... C'est lá vie!

Obrigado pelo interesse e pela ajuda.

Vou dando notícias!

[jpaulino 90]

Não há maneira mais fácil do que seleccionar a função, neste caso o Datediff e pressionar F1

[FranciscoF 0]

Lololol bem visto JPaulino!

(Só hoje é que vi qual a tecla de atalho para o help do Excel...)

Acho que vou começar o programa de raiz e testar cada módulo. Também tenho encontrado macros do Excel, como o Vlookup, etc, que me podem ajudar na minha tarefa e andar a consertar o programa com erros ajuda-me a ganhar experiencia, mas torna tudo mais confuso.

Vou atacar o programa de novo e quando obtiver resultados posto o código.

Em qualquer dos casos, obrigado pela ajuda!

[FranciscoF 0]

Olá boa tarde!

Depois de muitas tentativas e erro consegui finalmente executar o código que queria.

Neste momento ainda demora bastante tempo a correr, mas acho que não há muito a fazer , em função dos ciclos que implementei.

Option Explicit

Sub Elimina_Incoming()

' Macro implementada a 15.02 por FEF1AV

Dim Tamanho As Long
Dim Row As Variant
Dim j As Variant
Dim ref As Variant
Dim fornecedor As Variant
Dim S01 As Variant
Dim ContS01 As Integer
Dim difdata As Date
Dim S0_repet As Integer
Dim C_PPM As Integer
Dim T_Skip As Integer
Dim PPM_RS As Integer
Dim ref_PPM As Variant
Dim data_rej As Date
Dim data_rejdif As Integer

j = 1

' cria nova folha

Worksheets.Add , after:=Sheets(1)
Sheets(2).Name = ("Regra_Skip")

' cria o cabeçalho

Sheets(1).Activate
Cells(1).EntireRow.Select
Selection.Copy
Sheets("Regra_Skip").Activate
Selection.PasteSpecial Paste:=xlPasteValues

' cria as 4 colunas

Cells(1, "I").Value = "Nº Series Normais"
Cells(1, "J").Value = "Meses Ok"
Cells(1, "K").Value = "Data rejeição"
Cells(1, "L").Value = "PPM Ok?"

Sheets(1).Activate

'saber o tamanho da lista:

Tamanho = ActiveSheet.UsedRange.Rows.Count

Row = Tamanho

'Ciclo para as series 0

Do Until Row = 2

Cells(Row, "A").EntireRow.Select

    If Cells(Row, "F").Value = 101 And Cells(Row, "G").Value = 1 Then

' guarda referencia e fornecedor

    ref = Cells(Row, "B")
    fornecedor = Cells(Row, "E")
  
  ' avalia a presença de S0 repetidas em Regra Skip
    
    Sheets("Regra_Skip").Activate

        For S0_repet = 1 To j
            If Cells(S0_repet, "B") = ref And Cells(S0_repet, "E") = fornecedor Then GoTo a:
        
        Next S0_repet
    
    j = j + 1

    Sheets(1).Activate
    Cells(Row, "A").EntireRow.Select
    
    ' executa a diferença de datas
    difdata = DateDiff("m", Cells(Row, "H"), Now)
    
    Selection.Copy
    Sheets("Regra_Skip").Activate
    Cells(j, "A").EntireRow.Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Cells(j, "J") = difdata
    Sheets(1).Activate
    Cells(Row, "A").EntireRow.Delete

' Conta Nº se Series normais desde S0
    
    ContS01 = 0
    
    S01 = Row

        Do Until S01 = Tamanho
        
            Cells(S01, "A").EntireRow.Select
                
                If Cells(S01, "B") = ref And Cells(S01, "E") = fornecedor Then
                
                    If Cells(S01, "G") = "0" Or Cells(S01, "G") = "1" Or Cells(S01, "G") = "3" Then
                        ContS01 = ContS01 + 1

                        Else
                        ContS01 = 0
                        data_rej = Cells(S01, "H")
                        data_rejdif = DateDiff("m", Cells(S01, "H"), Now)
                        Sheets("Regra_Skip").Activate
                        Cells(j, "K") = data_rej
                        Cells(j, "J") = data_rejdif
                        Sheets(1).Activate
                        
                     End If
                     
                     Cells(S01, "A").EntireRow.Delete
                     S01 = S01 - 1
                     Tamanho = Tamanho - 1
                        
                 End If
                 
              S01 = S01 + 1
          Loop
    
    Sheets("Regra_Skip").Activate
    Cells(j, "I") = ContS01

       
End If

a:
Sheets(1).Activate
Row = Row - 1

Loop

' testa PPM para a lista obtida com 93 PPM >0

For C_PPM = 7 To 94

    Sheets("s911").Activate
    
        If Cells(C_PPM, "I") > 100 Then
        
            ref_PPM = Cells(C_PPM, "T")
            Sheets("Regra_Skip").Activate
            T_Skip = 564
                       
            For PPM_RS = 2 To T_Skip
                Cells(PPM_RS, "A").EntireRow.Select
                
                If Cells(PPM_RS, "B") = ref_PPM Then
                    Cells(PPM_RS, "L").Value = "Não"
                    
                End If
            
            Next PPM_RS
           
        End If
        
Next C_PPM

MsgBox "Fim!"

End Sub

Podem colocar o tópico como resolvido!

E obrigado pela ajuda!

Cumps! 

[jpaulino 90]

Neste momento ainda demora bastante tempo a correr, mas acho que não há muito a fazer , em função dos ciclos que implementei.

Vê se estas dicas ajudam: Excel: Dicas de VBA - Performance