Macros doing anything

T

Thestalos

New Member
Joined
May 4, 2022
Messages
1
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hi everyone, this is my first post and i new in vba.

i create 3 macros for a excel template, that get the data from the first sheet ("Dados") and do some filter in this data in the other 3 sheets. I upload this file in a internal system, that will use this template for download the data from other users.

After downloading from the system, only one macro is working ("atualizarDetalheNegociacao"), and macros ("atualizarResumoItem", "atualizarResumoTotal") IS NOT WORKING.
  • I compare my template file BEFORE uploading, but is the same thing code, nothing change.
  • I try to make a new sheet inside the template with the problem, using the same code, but the same error happens with the other two macros ("atualizarResumoItem", "atualizarResumoTotal"). The macro "atualizarDetalheNegociacao" continues to work, witch for me is strange;
  • I try to copy the code for the template with the problem to the template working, everthing works fine;
So, for me is a problem with the file configuration, but honestly i check the properties on the sheets and is same for everthing. When I debug on the template with error, i can see that the data from "Dados" is send for the other sheets (just the headers).

All sheets with macro have the same name of the macro

Here are the Macros:

VBA Code: 
Sub atualizarDetalheNegociacao()
    
    ' Get the worksheets
    Dim shRead As Worksheet, shWrite As Worksheet
    Set shRead = ThisWorkbook.Worksheets("Dados")
    Set shWrite = ThisWorkbook.Worksheets("Detalhes da Negociação")
    
    'mantem headers
    Dim rg As Range
    Set rg = ThisWorkbook.Worksheets("Detalhes da Negociação").Range("A1").CurrentRegion
    rg.Offset(1).ClearContents
    'se existe filtro mostre tudo
    If shRead.FilterMode = True Then
        shRead.ShowAllData
    End If
    'Range de dados é a aba Dados
    Dim rgData As Range, rgCriteria As Range
    Set rgData = shRead.Range("A1").CurrentRegion
    
    'aplicar os dados com base nos filtros
    rgData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=shWrite.Range("A2")
    
    shDetalhesNegocicao.Rows(2).EntireRow.Delete
    
End Sub
VBA Code: 
Sub atualizarResumoItem()
    
    ' Get the worksheets
    Dim shRead As Worksheet, shWrite As Worksheet
    Set shRead = ThisWorkbook.Worksheets("Dados")
    Set shWrite = ThisWorkbook.Worksheets("Resumo Por Item")
    'manter headers
    Dim rg As Range
    Set rg = ThisWorkbook.Worksheets("Resumo Por Item").Range("A1").CurrentRegion
    rg.Offset(1).ClearContents
    
    If shRead.FilterMode = True Then
        shRead.ShowAllData
    End If
    'Range de dados é a aba Dados
    Dim rgData As Range, rgCriteria As Range
    Set rgData = shRead.Range("A1").CurrentRegion
    'Criterio é : fornecedores com Status Participante Desqualificado = Não
    Set rgCriteria = ThisWorkbook.Worksheets("Filtros").Range("A1").CurrentRegion
    
     rgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rgCriteria _
         , CopyToRange:=shWrite.Range("A2")

    'Remove de maneira prática as linhas que não são necessárias
    
    'Deletar linha duplica do Header
    Rows(2).EntireRow.Delete
    
    
    shResumoItem.Activate
    'Ordernar por menor valor
    Range("E2", Range("E2").End(xlDown)).Sort Key1:=Range("E1"), Order1:=xlAscending
    'manter somente os menores valores removendo duplicatas baseado no nome do fornecedor/empresa
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
    
End Sub
VBA Code: 
Sub atualizarResumoTotal()

    ' Get the worksheets
    Dim shRead As Worksheet, shWrite As Worksheet
    Set shRead = ThisWorkbook.Worksheets("Dados")
    Set shWrite = ThisWorkbook.Worksheets("Resumo Total")
    'manter headers
    Dim rg As Range
    Set rg = ThisWorkbook.Worksheets("Resumo Total").Range("A1").CurrentRegion
    rg.Offset(1).ClearContents
    'colunas a serem enviadas para a aba
    shWrite.Range("A1").Value = "Empresa"
    ''shWrite.Range("B1").Value2 = "Melhor Preço Unitário"
    shWrite.Range("B1").Value = "Ciclo"
    shWrite.Range("C1").Value = "Forma de Pagamento"
    shWrite.Range("D1").Value2 = "Preço Total"
    shWrite.Range("E1").Value = "Incoterm"
    shWrite.Range("F1").Value = "Incoterm extra"
    shWrite.Range("G1").Value = "Local do incoterm"
    shWrite.Range("H1").Value2 = "Vencimento da proposta"
    shWrite.Range("I1").Value = "Moeda respondida"
    'se possui filtro mostra os dados
    If shRead.FilterMode = True Then
        shRead.ShowAllData
    End If
    
    Dim rgData As Range, rgCriteria As Range
    Set rgData = shRead.Range("A1").CurrentRegion
    'aplicar os dados com base nos filtros
    Set rgCriteria = ThisWorkbook.Worksheets("Filtros").Range("A1").CurrentRegion
    
     rgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rgCriteria _
                , CopyToRange:=shWrite.Range("A1:I1")
                
End Sub
    
Sub somaFornecedoresFiltro()

    Dim ar As Variant
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim str As String
    
    n = 1
    ar = shResumoTotal.Cells(1, 1).CurrentRegion.Value  'Aonde começar a buscar os dados (cabeçalhos contam)
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(ar, 1)
            str = ar(i, 1) 'Qual coluna será usada como chave para filtrar
            If Not .exists(str) Then
                n = n + 1
                For j = 1 To UBound(ar, 2)
                    ar(n, j) = ar(i, j)
                Next
                .Item(str) = n
            Else
                For j = 4 To 4 'range que deve ser feito os cálculos. Caso precise aumentar trocar o segundo 4, exemplo ler da 4 até 6, logo for 4 To 6
                    ar(.Item(str), j) = ar(.Item(str), j) + ar(i, j)
                Next
            End If
        Next
    End With
    Set rg = ThisWorkbook.Worksheets("Resumo Total").Range("A1").CurrentRegion 'limpar dados para inserir apos filtro
    rg.Offset(1).ClearContents
    shResumoTotal.Range("A2").Resize(n, UBound(ar, 2)).Value = ar 'voltar os dados pr
    Rows(2).EntireRow.Delete 'deletar o cabeçalho que vai ser copiado duas vezes
End Sub
Comparative Map - DESQUALIFICADO (1).xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARAS
1Código do ItemDescriçãoQuantidade de itensEmpresaMelhor Preço UnitárioEndereço por RFQCicloParticipante PremiadoForma de PagamentoPreço UnitárioPreço TotalPreço Total ConvertidoPrazo de Entrega em DiasMelhor Preço Por ItemValor do FreteBase IPI% IPINCMBase ICMS% ICMSSubstituição tributáriaID ItemIncotermIncoterm extraLocal do incotermVencimento da propostaTipo do itemMoeda respondidaPreço de ultima compraValor de referenciaCFOPOrigem do MaterialUnidade de MedidaValor do frete incluso no preço unitárioTotal dos impostos internacionaisImpostos internacionais inclusosICMS InclusoAlíquota do ISSISS InclusoAlíquota do PISPIS InclusoAlíquota do CofinsCofins InclusoIPI InclusoParticipante Desqualificado
201Item 011,00000BRUNO GAMES 7.0 FORNECEDOR 001200,00000VERDADEIRO1FALSO60 dias200,00000200,000000,0000020VERDADEIRO0,000000,000000,000000,000000,00000Not informed175196CFRFornecedorRJ131/05/2022 00:00:00GoodsBRL0,00000190,00000metroNo0,00000NoNo0No0No0NoNoNo
301Item 011,00000Empresa 02 - Tijolos 200,00000VERDADEIRO1FALSO60 dias500,00000500,000000,0000050FALSO0,000000,000000,000000,000000,00000Not informed175196CFRFornecedorRJ131/05/2022 00:00:00GoodsBRL0,00000190,00000metroNo0,00000NoNo0No0No0NoNoNo
402item 021,00000BRUNO GAMES 7.0 FORNECEDOR 001100,00000VERDADEIRO1FALSO60 dias300,00000300,000000,0000020FALSO0,000000,000000,000000,000000,00000Not informed175197CFRFornecedorRJ131/05/2022 00:00:00ServiceBRL0,00000200,00000metroNo0,00000NoNo0No0No0NoNoNo
502item 021,00000Empresa 02 - Tijolos 100,00000VERDADEIRO1FALSO60 dias100,00000100,000000,0000050VERDADEIRO0,000000,000000,000000,000000,00000Not informed175197CFRFornecedorRJ131/05/2022 00:00:00ServiceBRL0,00000200,00000metroNo0,00000NoNo0No0No0NoNoNo
Dados

Comparative Map - DESQUALIFICADO (1).xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASAT
1Código do ItemDescriçãoQuantidade de itensEmpresaMelhor Preço UnitárioEndereço por RFQCicloParticipante PremiadoForma de PagamentoPreço UnitárioPreço TotalPreço Total ConvertidoPrazo de Entrega em DiasMelhor Preço Por ItemValor do FreteBase IPI% IPINCMBase ICMS% ICMSSubstituição tributáriaID ItemIncotermIncoterm extraLocal do incotermVencimento da propostaTipo do itemMoeda respondidaPreço de ultima compraValor de referenciaCFOPOrigem do MaterialUnidade de MedidaValor do frete incluso no preço unitárioTotal dos impostos internacionaisImpostos internacionais inclusosICMS InclusoAlíquota do ISSISS InclusoAlíquota do PISPIS InclusoAlíquota do CofinsCofins InclusoIPI InclusoParticipante Desqualificado
201Item 011,00000BRUNO GAMES 7.0 FORNECEDOR 001200,00000########1FALSO60 dias200,00000200,000000,0000020########0,000000,000000,000000,000000,00000Not informed175196CFRFornecedorRJ131/05/2022 00:00:00GoodsBRL0,00000190,00000metroNo0,00000NoNo0No0No0NoNoNo
301Item 011,00000Empresa 02 - Tijolos 200,00000########1FALSO60 dias500,00000500,000000,0000050FALSO0,000000,000000,000000,000000,00000Not informed175196CFRFornecedorRJ131/05/2022 00:00:00GoodsBRL0,00000190,00000metroNo0,00000NoNo0No0No0NoNoNo
402item 021,00000BRUNO GAMES 7.0 FORNECEDOR 001100,00000########1FALSO60 dias300,00000300,000000,0000020FALSO0,000000,000000,000000,000000,00000Not informed175197CFRFornecedorRJ131/05/2022 00:00:00ServiceBRL0,00000200,00000metroNo0,00000NoNo0No0No0NoNoNo
502item 021,00000Empresa 02 - Tijolos 100,00000########1FALSO60 dias100,00000100,000000,0000050########0,000000,000000,000000,000000,00000Not informed175197CFRFornecedorRJ131/05/2022 00:00:00ServiceBRL0,00000200,00000metroNo0,00000NoNo0No0No0NoNoNo
6
Detalhes da Negociação
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
You must log in or register to reply here.

Similar threads

Q
  • Solved
How to stop InputBox from looping after input?
Replies
7
Views
479
qplsn9
Q
B
  • Question Question
VBA Macro Not Detecting Slicer Correctly in Excel Workbook
Replies
0
Views
599
bigodudo
B
9
  • Question Question
Filter, Count Filtered results, Copy the Filtered result to Next sheet using VBA.
Replies
1
Views
601
99Ahmad99
9
I
  • Question Question
Exclude a specific value in a select row in list box, into multiple sheets
Replies
0
Views
598
inactiveUser214710
I
J
  • Question Question
Loop Through Multiple Columns, Match Against Criteria and Paste Cell in Blank Workbook...
Replies
0
Views
358
juanbolas
J

Forum statistics

Threads
1,223,896
Messages
6,175,259
Members
452,626
Latest member
huntinghunter

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top