Oi pessoal, tudo bem?
Começo dizendo que não posso subir o arquivo 
sorry.
O que acontece é o seguinte:
Trabalho numa empresa e preciso conferir o valor do XML (NFE) com o orçamento realizado no ano.
Esse orçamento está fora do sistema, e o objetivo é validar se o produto comprado está com o preço dentro do orçado, e então tomar as medidas devidas.
Eu construi um frankstein, que ficava muito pesado o arquivo, e passados alguns uploads ele travava. Estava subindo +1500 XMLs de uma vez, demorando algo em torno de 14min (achei bom) só que o arquivo ficava com 8-9mb (o que não é muito). Essa super-carga é de 01/2016 até 01/2017. Fev desse ano eu subi somente o mês, e subindo somente uns 100 arquivos, na hora de salvar o excel falava que não era possível (2010).
Para resolver isso, fui atrás de maneiras de reduzir o tempo/peso do processamento da macro, e dentre varias respostas muito úteis, encontrei uma que me pareceu bastante sensata: "De o menos de Worksheet.Select possível. Se conseguir, tente copiar utilizando Base_R.Range("B6").Copy Destination:=Base_R.Range("D5")" por exemplo.
Esse exemplo que eu dei acima é real em uma de minhas planilhas e funciona, onde Base_R está nomeado como worksheet global.
Aqui está o código (vou explicar abaixo):
Public Property Get XMLdb() As Worksheet
Set XMLdb = Worksheets("XMLDatabase")
'Nomear aba publica
End Property
Public Property Get AI1() As Worksheet
Set AI1 = Worksheets("AuxInput1")
'Nomear aba publica
End Property
Public Property Get Cnslt() As Worksheet
Set Cnslt = Worksheets("Consulta")
'Nomear aba publica
End Property
Public Property Get FTU() As Worksheet
Set FTU = Worksheets("FileToUpload")
'Nomear aba publica
End Property
Public Property Get Menu() As Worksheet
Set Menu = Worksheets("Menu")
'Nomear aba publica
End Property
Function GetTableName(AI1) As String
GetTableName = AI1.ListObjects(1).Name
With AI1.ListObjects(GetTableName)
Set rList = .Range
.Unlist
End With
'Remover "Table" para linha comum
End Function
Sub ImportarIndividual()
Application.DisplayAlerts = False
'Selecao de arquivo externo ao excel de forma unitaria
Dim Caminho As String, fDialog As Office.FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.AllowMultiSelect = False
.Title = "Selecionar arquivo..."
.Filters.Clear
.Filters.Add "Arquivos Excel - .xml", "*.xml"
If .Show = True Then
Caminho = .SelectedItems.Item(1)
Else
MsgBox "Você clicou em cancelar"
Menu.Select
End
End If
End With
FTU.Select
With ActiveSheet
.Cells.Delete
.Cells(1, 1) = Array("Caminho")
Cells(2, 1) = Caminho
End With
'Call Importar
Application.DisplayAlerts = True
Menu.Select
MsgBox "Carregamento Completo"
End Sub
Sub ImportarPasta()
Application.DisplayAlerts = False
Dim Caminho As String
Dim CamPasta As String
Dim fDialog As Office.FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.AllowMultiSelect = False
.Title = "Selecionar pasta..."
.Filters.Clear
If .Show = True Then
CamPasta = .SelectedItems.Item(1)
Else
MsgBox "Você clicou em cancelar"
Menu.Select
End
End If
End With
Dim fso, flw, fl As Object, n As Long
Set fso = CreateObject("Scripting.FilesystemObject")
Set fld = fso.getfolder(CamPasta)
FTU.Select
With ActiveSheet
.Cells.Delete
.Range("a1:b1") = Array("Caminho", "Nome")
n = 2
For Each fl In fld.Files
.Cells(n, "a") = fl.Path
.Cells(n, "b") = fl.Name
n = n + 1
Next fl
End With
'Call Importar
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Menu.Select
MsgBox "Carregamento completo"
End Sub
Sub Importar()
'Inicial dos arquivos a serem carregados
o = 2
'Contar qtde. de arquivos a serem carregados
uArq = FTU.Columns(1).End(xlDown).Row
'Cam é o arquivo a ser selecionado
Dim Cam As String
'loop para novos arquivos
While o <= uArq
Cam = FTU.Cells(o, 1) 'pega o caminho do arquivo
'Limpa AI1 para colar novos dados
AI1.AutoFilterMode = False
AI1.Cells.Delete
'Upload de arquivo selecionado e limpeza da tabela
AbrirArquivo = Cam
ActiveWorkbook.XmlImport URL:=AbrirArquivo, ImportMap:=Nothing, Overwrite:=True, Destination:=AI1.Cells(1, 1)
Call GetTableName(AI1)
'B Buscar colunas a serem utilizadas para verificar validade do arquivo XML
Dim BId, BCorr, BnatOp As Object
With AI1.Rows(1)
Set BCorr = .Find("ns1:xCorrecao", LookIn:=xlValues)
Set BnatOp = .Find("ns3:natOp", LookIn:=xlValues)
Set BId = .Find("Id", LookIn:=xlValues)
End With
'Validacao de colunas para identificar arquivos validos
EndId = BId.Column 'Verifica se o XML já foi utilizado
ValorId = AI1.Cells(2, EndId)
CheckId = Application.WorksheetFunction.CountIf(XMLdb.Columns(2), ValorId)
If CheckId = 0 Then
Else
GoTo iProxXML 'Se tiver repetido pula para o proximo XML
End If
'Verifica tipos de XML que nao serao utilizados
If BCorr Is Nothing Then
Else
GoTo iProxXML
End If
If BnatOp Is Nothing Then
Else
EndnatOp = BnatOp.Column
inatOp = WorksheetFunction.Match("Transporte", Columns(EndnatOp), 1)
If inatOp < 0 Then
Else
GoTo iProxXML
End If
End If
'Verificar se tem mais de uma linha igual
iUltCol = AI1.Rows(1).End(xlToRight).Column
Dim BcProd, BxProd, BqCom, BvProd As Object
With AI1.Rows(1)
Set BcProd = .Find("ns1:cProd", LookIn:=xlValues) 'aqui eu crio a referencia para encontrar o endereco
Set BxProd = .Find("ns1:xProd", LookIn:=xlValues)
Set BqCom = .Find("ns1:qCom", LookIn:=xlValues)
Set BvProd = .Find("ns1:vProd", LookIn:=xlValues)
End With
CcProd = BcProd.Column 'aqui eu pego o No da coluna que desejo
CxProd = BxProd.Column
CqCom = BqCom.Column
CvProd = BvProd.Column
'Loop para validar linhas repetidas
iLin = 2
iULinhaAI1 = AI1.Columns(1).End(xlDown).Row
While iLin <= iULinhaAI1
AI1.Cells(iLin, iUltCol + 1).Formula = Cells(iLin, CcProd) & Cells(iLin, CxProd) & Cells(iLin, CqCom) & Cells(iLin, CvProd)
AI1.Cells(iLin, iUltCol + 2).Formula = WorksheetFunction.CountIf(Range(Cells(1, iUltCol + 1), Cells(iLin, iUltCol + 1)), Cells(iLin, iUltCol + 1))
iLin = iLin + 1
Wend
AI1.AutoFilterMode = False
AI1.Rows(1).AutoFilter field:=iUltCol + 2, Criteria1:="<1", Operator:=xlOr, Criteria2:=">1" 'esse filtro exclui o 1 (item unico) e habilita excluir demais itens
AI1.Range(Rows(2), Rows(iULinhaAI1)).SpecialCells(xlCellTypeVisible).Delete
'Filtrar somente CFOPs utilizadas
AI1.AutoFilterMode = False
EndCFOP = WorksheetFunction.Match("ns1:CFOP", Rows(1), 0)
AI1.Rows(1).AutoFilter field:=EndCFOP, Criteria1:=Array("5101", "5124", "5102", "6102", "6101", "6124"), field:=iUltCol2 + 1, Criteria2:="2", Operator:=xlFilterValues
'Calculo do range limite para transferencia de dados
uLinhaAI12 = AI1.Columns(1).End(xlDown).Row
uLinhaXMLdb1 = XMLdb.Columns(1).End(xlDown).Row
uCnslt = Cnslt.Columns(1).End(xlDown).Row
'Loop de cópia
j = 2
Dim Cnslt1 As Range, BuscarRef1, BuscarRef2 As Variant
While j <= uCnslt
Set Cnslt1 = Cnslt.Cells(j, 1)
'Transferindo dados AI1 para XMLdb
With AI1.Rows(1)
Set BuscarRef1 = .Find(Cnslt1, LookIn:=xlValues) 'vai procurar coluna para puxar dados
If BuscarRef1 Is Nothing Then
Set BuscarRef1 = .Find("ns1:CNPJ", LookIn:=xlValues) 'Aqui é caso o CNPJ de algum problema, utiliza esse valor"ns1:CNPJ"
Else
End If
EndX = BuscarRef1.Column 'Traz a ref para copiar valores
End With
With XMLdb.Rows(1)
Set BuscarRef2 = .Find(Cnslt1, LookIn:=xlValues)
EndY = BuscarRef2.Column 'Traz a referencia para colar valores
End With
AI1.Range(Cells(2, EndX), Cells(uLinhaAI12, EndX)).SpecialCells(xlCellTypeVisible).Select
'XMLdb.Select
'XMLdb.Range("A2").Select
Wend
iProxXML:
o = o + 1
Wend
End Sub
Vou explicar:
o que é: "Public Property Get" serve para nomear a Worksheets para todas as macros, assim não preciso ficar dando Dim em todas elas;
- "Function GetTableName(AI1)" tive que construir separado para tirar o "Table" do arquivo XML carregado (não consegui incluir ele na Macro, tenho que dar um Call)
- As subs "ImportarIndividual" e "ImportarPasta". Com elas eu chamo um "abrir" arquivo (filtrado XML) ou a pasta inteira. Isso cola em uma aba chamada "FileToUpload(FTU)".
- Macro "Importar": ela começa puxando o caminho por caminho dos XMLs a serem importados, abre, tira o table, seleciona somente CFOP (cod de compra) necessários, tira duplicados, copia e cola na aba XMLDatabase (XMLdb), e volta pro Loop
O meu problema é que eu quero usar a função destination direto da aba AI1 (AuxInput1, onde sobem os arquivos XML) para a aba XMLdb (onde fica recordado).
não aceita o AI1.Range(xxx).Select (ou Copy, ou outro), sem estar na aba AI1 selecionada. O mesmo ocorre para o XMLdb.Range(XXX).Select (ou pastespecial, etc)
'Calculo do range limite para transferencia de dados
uLinhaAI12 = AI1.Columns(1).End(xlDown).Row
uLinhaXMLdb1 = XMLdb.Columns(1).End(xlDown).Row
uCnslt = Cnslt.Columns(1).End(xlDown).Row
'Loop de cópia
j = 2
Dim Cnslt1 As Range, BuscarRef1, BuscarRef2 As Variant
While j <= uCnslt
Set Cnslt1 = Cnslt.Cells(j, 1)
'Transferindo dados AI1 para XMLdb
With AI1.Rows(1)
Set BuscarRef1 = .Find(Cnslt1, LookIn:=xlValues) 'vai procurar coluna para puxar dados
If BuscarRef1 Is Nothing Then
Set BuscarRef1 = .Find("ns1:CNPJ", LookIn:=xlValues) 'Aqui é caso o CNPJ de algum problema, utiliza esse valor"ns1:CNPJ"
Else
End If
EndX = BuscarRef1.Column 'Traz a ref para copiar valores
End With
With XMLdb.Rows(1)
Set BuscarRef2 = .Find(Cnslt1, LookIn:=xlValues)
EndY = BuscarRef2.Column 'Traz a referencia para colar valores
End With
AI1.Range(Cells(2, EndX), Cells(uLinhaAI12, EndX)).SpecialCells(xlCellTypeVisible).Select
Na última linha que está dando problema.
Porque fazer nesse nível: as linhas e colunas são muitas e dinâmicas, por isso tudo das buscas!
Se ficou alguma duvida me avisa,
É só isso que falta para encerrar (espero)
O resto, espero estar bem comentado, para que o pessoal possa usar de referencia!
Se puderem ajudar, obrigado,
Abrcs
HFava