Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Criar ajuste em mac...
 
Notifications
Clear all

Criar ajuste em macro gravada

 
2024 - VBA & Macros
Post Recente por klarc28 7 anos atrás
7 Posts
2 Usuários
0 Reactions
1,390 Visualizações
RSS
 JNEXCEL
(@jnexcel)
Posts: 298
Reputable Member
Topic starter
 

Prezados, boa tarde.

eu estou com problemas com o arquivo do link.

https://drive.google.com/file/d/1diEf-2 ... sp=sharing

vai aparecer uma mensagem informando que houve um problema na visualização do arquivo, porém é só clicar em download.

alguém poderia colaborar com o loop?

agradeço pela atenção de todos.

 
Postado : 26/04/2018 12:34 pm
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 

Coloque um título específico no seu tópico. Qual problema? Qual loop?

 
Postado : 26/04/2018 3:36 pm
 JNEXCEL
(@jnexcel)
Posts: 298
Reputable Member
Topic starter
 

Bom dia!

Ok, vamos lá.

funções:

eu tenho uma planilha para importar dados de um xml de nfe, uma macro que copia algumas informações e cola em uma segunda planilha e uma outra macro para limpar os dados da segunda planilha.

porém eu não estou conseguindo usar a segunda macro "macro para copiar".

o que eu preciso:

quando eu importar os dados de uma xml de nfe, e depois clicar em copiar dados, todos os itens existentes serão copiados no formato definido, atualmente eu consigo fazer isso apenas para um item, por essa razão eu gostaria de uma colaboração para criar um loop e preencher os dados.

código para importar dados de um xml de nfe: 

'Desenvolvido por Fabio Mitsueda
'http://fabiomitsueda.com.br
'Data da finalização 05/03/2018
Option Explicit

'Importante fazer referencia as dlls:
'Microsoft XML, v6.0
'Microsoft Scripting Runtime

Sub PastaXml()
    'Declaração de variaves de objeto a serem utilizadas para percorrer os arquivos na pasta selecionada
    Dim objFSO      As Scripting.FileSystemObject
    Dim objFolder   As Scripting.Folder
    Dim objFile     As Scripting.File
    'Declarando variavel que será carregada com o nome do arquivo
    Dim strCaminho  As String
    Dim i           As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            strCaminho = .SelectedItems(1)
            Set objFSO = New Scripting.FileSystemObject
            Set objFolder = objFSO.GetFolder(strCaminho)
            For Each objFile In objFolder.Files
                If objFSO.GetExtensionName(objFile.Path) = "xml" Then
                    LerXml (strCaminho & "" & objFile.Name)
                    i = i + 1
                End If
            Next
            
'            MsgBox "Processo Finalizado!!!" & vbCrLf & vbCrLf & _
                   '"Foi feita leitura de " & i & " arquivos XML", vbOKOnly
           

        End If
    End With

    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objFile = Nothing
End Sub

Sub LerXml(ByVal strFolderPath As String)
    
    'Declaração de variaveis de objeto para leitura do XML
    Dim xmlDoc      As DOMDocument
    Dim xmlList     As IXMLDOMNodeList
    Dim xmlNode     As IXMLDOMNode
    
    'Declaração de variaveis diversas para o código
    Dim shtXml      As Worksheet
    Dim strXml      As String
    Dim x, y, i     As Long
    Dim objPasta    As FileDialog
    
    'Declaração de variaveis de retorno do XML
    Dim strVersao   As String
    Dim strEmitente As String
    Dim strCNPJEmi  As String
    Dim strIEEmite  As String
    Dim strRegTrib  As String
    Dim strNoNFe    As String
    Dim strSerie    As String
    Dim strDEmi     As String
    Dim strChaveNFe As String
    Dim strCodProd  As String
    Dim strDescric  As String
    Dim strNCM      As String
    Dim intCFOP     As Integer
    Dim strEAN      As String
    Dim strEANTrib  As String
    Dim dblQtdCom   As Double
    Dim dblQtdTri   As Double
    Dim dblVlrCom   As Double
    Dim dblVlrTri   As Double
    Dim strVlrFrt   As String
    Dim dblVlrFrt   As Double
    Dim strVlrSeg   As String
    Dim dblVlrSeg   As Double
    Dim strVlrDes   As String
    Dim dblVlrDes   As Double
    Dim strVlrOut   As String
    Dim dblVlrOut   As Double
    Dim dblVlrTot   As Double
    Dim strIcmsOr   As String
    Dim strIcmsCst  As String
    Dim strIcmsVlr  As String
    Dim dblIcmsVlr  As Double
    Dim strIcmsAlq  As String
    Dim dblIcmsAlq  As Double
    Dim strPisCST   As String
    Dim strPisAlq   As String
    Dim dblPisAlq   As Double
    Dim strPisVlr   As String
    Dim dblPisVlr   As Double
    Dim strCofinCST As String
    Dim strCofinAlq As String
    Dim dblCofinAlq As Double
    Dim strCofinVlr As String
    Dim dblCofinVlr As Double
    Dim strIcmsBcSt As String
    Dim dblIcmsBcSt As Double
    Dim strIcmsStVr As String
    Dim dblIcmsStVr As Double
    Dim strIpiCST   As String
    Dim strIpiVr    As String
    Dim dblIpiVr    As Double
    
    'Atribuindo caminho do arquivo a variavel
    strXml = strFolderPath
    
    'Carregando o objeto que irá representar o documento XML
    Set xmlDoc = New DOMDocument
    
    'Carregando o arquivo
    xmlDoc.Load (strXml)
    
    'Versão da NFE
    For i = 0 To xmlDoc.SelectSingleNode("/nfeProc/NFe/infNFe").Attributes.Length - 1
        If LCase(xmlDoc.SelectSingleNode("/nfeProc/NFe/infNFe").Attributes(i).nodeName) = "versao" Then
            strVersao = xmlDoc.SelectSingleNode("/nfeProc/NFe/infNFe").Attributes(i).NodeValue
            Exit For
        End If
    Next
       
    'Leitura da Tag ide
    For Each xmlNode In xmlDoc.getElementsByTagName("ide")
        'Verificar se o XML é Nfe pela existencia da Tag numero da nNF (número da nota)
        If xmlNode.SelectNodes("nNF").Length = 0 Then
            MsgBox "Não é um xml"
            Exit Sub
        End If
        
        'Numero da nota fiscal
        strNoNFe = xmlNode.SelectNodes("nNF")(0).Text
        
        'Série da nota fiscal
        strSerie = xmlNode.SelectNodes("serie")(0).Text
        
        'Data de emissão
        Select Case strVersao
            Case "4.00"
                strDEmi = VBA.Format(VBA.Left(xmlNode.SelectNodes("dhEmi")(0).Text, 10), "dd/mm/yyyy")
            Case "3.10"
                strDEmi = VBA.Format(VBA.Left(xmlNode.SelectNodes("dhEmi")(0).Text, 10), "dd/mm/yyyy")
            Case Else
                strDEmi = VBA.Format(xmlNode.SelectNodes("dEmi")(0).Text, "dd/mm/yyyy")
        End Select
    Next
    
    'Leitura da Tab emit (Emitente)
    For Each xmlNode In xmlDoc.getElementsByTagName("emit")
        'Razão social do emitente
        strEmitente = xmlNode.SelectNodes("xNome")(0).Text
        'CNPJ do emitente
        strCNPJEmi = "'" & xmlNode.SelectNodes("CNPJ")(0).Text
        'Inscrição Estadual do emitente
        strIEEmite = "'" & xmlNode.SelectNodes("IE")(0).Text
        'Regime tributario
        x = xmlNode.SelectNodes("CRT")(0).Text
        Select Case x
            Case 1
                strRegTrib = "Simples Nacional"
            Case 2
                strRegTrib = "Simples Nacional, excesso sublimite de receita bruta"
            Case 3
                strRegTrib = "Regime Normal"
        End Select
    Next
    
    'Chave da NFe
    For Each xmlNode In xmlDoc.getElementsByTagName("infProt")
        If xmlNode.SelectNodes("chNFe").Length > 0 Then
            strChaveNFe = "'" & xmlNode.SelectNodes("chNFe")(0).Text
        End If
    Next
    
    Set shtXml = ThisWorkbook.Sheets("LerXml")
    
    i = shtXml.Range("A1048576").End(xlUp).Row + 1
    
    'Aqui vamos iniciar a ler os produtos da nota fiscal e carregar as linhas no excel conforme esses produtos
    Set xmlList = xmlDoc.getElementsByTagName("det")
    For Each xmlNode In xmlList
        strVlrFrt = ""
        dblVlrFrt = 0
        strVlrSeg = ""
        dblVlrSeg = 0
        strVlrDes = ""
        dblVlrDes = 0
        strVlrOut = ""
        dblVlrOut = 0
        strIcmsVlr = ""
        dblIcmsVlr = 0
        strIcmsAlq = ""
        dblIcmsAlq = 0
        strPisAlq = ""
        dblPisAlq = 0
        strPisVlr = ""
        dblPisVlr = 0
        strCofinAlq = ""
        dblCofinAlq = 0
        strCofinVlr = ""
        dblCofinVlr = 0
        strIcmsBcSt = ""
        dblIcmsBcSt = 0
        strIcmsStVr = ""
        dblIcmsStVr = 0
        strIpiVr = ""
        dblIpiVr = 0
        
        strCodProd = GetNodeValue(xmlNode, "prod/cProd")
        strDescric = GetNodeValue(xmlNode, "prod/xProd")
        strNCM = GetNodeValue(xmlNode, "prod/NCM")
        intCFOP = GetNodeValue(xmlNode, "prod/CFOP")
        strEAN = "'" & GetNodeValue(xmlNode, "prod/cEAN")
        If strEAN = "'" Then strEAN = ""
        strEANTrib = "'" & GetNodeValue(xmlNode, "prod/cEANTrib")
        If strEANTrib = "'" Then strEANTrib = ""
        dblQtdCom = VBA.Replace(GetNodeValue(xmlNode, "prod/qCom"), ".", ",")
        dblQtdTri = VBA.Replace(GetNodeValue(xmlNode, "prod/qTrib"), ".", ",")
        dblVlrCom = VBA.Replace(GetNodeValue(xmlNode, "prod/vUnCom"), ".", ",")
        dblVlrTri = VBA.Replace(GetNodeValue(xmlNode, "prod/vUnTrib"), ".", ",")
        
        strVlrFrt = VBA.Replace(GetNodeValue(xmlNode, "prod/vFrete"), ".", ",")
        If strVlrFrt <> "" Then
            dblVlrFrt = strVlrFrt
        End If
        
        strVlrSeg = VBA.Replace(GetNodeValue(xmlNode, "prod/vSeg"), ".", ",")
        If strVlrSeg <> "" Then
            dblVlrSeg = strVlrSeg
        End If
        
        strVlrDes = VBA.Replace(GetNodeValue(xmlNode, "prod/vDesc"), ".", ",")
        If strVlrDes <> "" Then
            dblVlrDes = strVlrDes
        End If
        
        strVlrOut = VBA.Replace(GetNodeValue(xmlNode, "prod/vOutro"), ".", ",")
        If strVlrOut <> "" Then
            dblVlrOut = strVlrOut
        End If
        
        dblVlrTot = VBA.Replace(GetNodeValue(xmlNode, "prod/vProd"), ".", ",")
        
        strIcmsOr = GetICMS(xmlNode, 1)
        
        strIcmsCst = "'" & GetICMS(xmlNode, 2)
        If strIcmsCst = "'" Then strIcmsCst = ""
        
        strIcmsVlr = VBA.Replace(GetICMS(xmlNode, 3), ".", ",")
        If strIcmsVlr <> "" Then
            dblIcmsVlr = strIcmsVlr
        End If
        
        strIcmsAlq = VBA.Replace(GetICMS(xmlNode, 4), ".", ",")
        If strIcmsAlq <> "" Then
            dblIcmsAlq = strIcmsAlq
            dblIcmsAlq = dblIcmsAlq / 100
        End If
        
        strPisCST = "'" & GetPIS(xmlNode, 1)
        If strPisCST = "'" Then strPisCST = ""
        
        strPisAlq = VBA.Replace(GetPIS(xmlNode, 2), ".", ",")
        If strPisAlq <> "" Then
            dblPisAlq = strPisAlq
            dblPisAlq = dblPisAlq / 100
        End If
        
        strPisVlr = VBA.Replace(GetPIS(xmlNode, 3), ".", ",")
        If strPisVlr <> "" Then
            dblPisVlr = strPisVlr
        End If
        
        strCofinCST = "'" & GetCOFINS(xmlNode, 1)
        If strCofinCST = "'" Then strCofinCST = ""
        
        strCofinAlq = VBA.Replace(GetCOFINS(xmlNode, 2), ".", ",")
        If strCofinAlq <> "" Then
            dblCofinAlq = strCofinAlq
            dblCofinAlq = dblCofinAlq / 100
        End If
        
        strCofinVlr = VBA.Replace(GetCOFINS(xmlNode, 3), ".", ",")
        If strCofinVlr <> "" Then
            dblCofinVlr = strCofinVlr
        End If
        '''''''''''
        strIcmsBcSt = VBA.Replace(GetICMS(xmlNode, 5), ".", ",")
        If strIcmsBcSt <> "" Then
            dblIcmsBcSt = strIcmsBcSt
        End If
        
        strIcmsStVr = VBA.Replace(GetICMS(xmlNode, 6), ".", ",")
        If strIcmsStVr <> "" Then
            dblIcmsStVr = strIcmsStVr
        End If
        
        strIpiCST = "'" & GetIPI(xmlNode, 1)
        If strIpiCST = "'" Then strIpiCST = ""
        
        strIpiVr = VBA.Replace(GetIPI(xmlNode, 2), ".", ",")
        If strIpiVr <> "" Then
            dblIpiVr = strIpiVr
        End If
        
        'Carregando informações na planilha
        shtXml.Cells(i, 1).Value = strEmitente
        shtXml.Cells(i, 2).Value = strCNPJEmi
        shtXml.Cells(i, 3).Value = strIEEmite
        shtXml.Cells(i, 4).Value = strRegTrib
        shtXml.Cells(i, 5).Value = strNoNFe
        shtXml.Cells(i, 6).Value = strSerie
        shtXml.Cells(i, 7).Value = strDEmi
        shtXml.Cells(i, 8).Value = strChaveNFe
        shtXml.Cells(i, 9).Value = strCodProd
        shtXml.Cells(i, 10).Value = strDescric
        shtXml.Cells(i, 11).Value = strNCM
        shtXml.Cells(i, 12).Value = intCFOP
        shtXml.Cells(i, 13).Value = strEAN
        shtXml.Cells(i, 14).Value = strEANTrib
        shtXml.Cells(i, 15).Value = dblQtdCom
        shtXml.Cells(i, 16).Value = dblQtdTri
        shtXml.Cells(i, 17).Value = dblVlrCom
        shtXml.Cells(i, 18).Value = dblVlrTri
        shtXml.Cells(i, 19).Value = dblVlrFrt
        shtXml.Cells(i, 20).Value = dblVlrSeg
        shtXml.Cells(i, 21).Value = dblVlrDes
        shtXml.Cells(i, 22).Value = dblVlrOut
        shtXml.Cells(i, 23).Value = dblVlrTot
        shtXml.Cells(i, 24).Value = strIcmsOr
        shtXml.Cells(i, 25).Value = strIcmsCst
        shtXml.Cells(i, 26).Value = dblIcmsAlq
        shtXml.Cells(i, 27).Value = dblIcmsVlr
        shtXml.Cells(i, 28).Value = dblIcmsBcSt
        shtXml.Cells(i, 29).Value = dblIcmsStVr
        shtXml.Cells(i, 30).Value = strPisCST
        shtXml.Cells(i, 31).Value = dblPisAlq
        shtXml.Cells(i, 32).Value = dblPisVlr
        shtXml.Cells(i, 33).Value = strCofinCST
        shtXml.Cells(i, 34).Value = dblCofinAlq
        shtXml.Cells(i, 35).Value = dblCofinVlr
        shtXml.Cells(i, 36).Value = strIpiCST
        shtXml.Cells(i, 37).Value = dblIpiVr
        i = i + 1
    Next

    Set shtXml = Nothing
    Set xmlList = Nothing
    Set xmlNode = Nothing
    Set xmlDoc = Nothing
End Sub

Function GetNodeValue(node As IXMLDOMNode, xp As String)
    Dim n As IXMLDOMNode, nv
    Set n = node.SelectSingleNode(xp)
    If Not n Is Nothing Then nv = n.nodeTypedValue
    GetNodeValue = nv
    Set n = Nothing
End Function

Function GetICMS(ByVal node As IXMLDOMNode, ByVal intCampo As Integer)
'Caso a opção intCampo seja:
'1 = origem
'2 = CST/COSN
'3 = Valor do ICMS
'4 = Aliquota ICMS
'5 = Base de calculo ICMS ST
'6 = Valor ICMS ST

    Dim strCampo    As String
    Dim strCampoSn  As String
    Select Case intCampo
        Case 1
            strCampo = "orig"
            strCampoSn = "orig"
        Case 2
            strCampo = "CST"
            strCampoSn = "CSOSN"
        Case 3
            strCampo = "vICMS"
            strCampoSn = "vICMS"
        Case 4
            strCampo = "pICMS"
            strCampoSn = "pICMS"
        Case 5
            strCampo = "vBCST"
            strCampoSn = "vBCST"
        Case 6
            strCampo = "vICMSST"
            strCampoSn = "vICMSST"
            
    End Select
    
    Dim n As IXMLDOMNode, nv
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS00/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS10/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS20/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS30/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS40/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS41/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS50/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS51/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS60/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS70/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMS90/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN101/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN102/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN103/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN201/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN202/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN203/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN300/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN400/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN500/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/ICMS/ICMSSN900/" & strCampoSn)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
Fim:

    GetICMS = nv
    Set n = Nothing
End Function


Function GetPIS(ByVal node As IXMLDOMNode, ByVal intCampo As Integer)
'Caso a opção intCampo seja:
'1 = CST
'2 = Aliquota PIS
'3 = Valor PIS

    Dim strCampo    As String
    Select Case intCampo
        Case 1
            strCampo = "CST"
        Case 2
            strCampo = "pPIS"
        Case 3
            strCampo = "vPIS"
    End Select
    
    Dim n As IXMLDOMNode, nv
    Set n = node.SelectSingleNode("imposto/PIS/PISAliq/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/PIS/PISQtde/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/PIS/PISNT/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/PIS/PISOutr/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/PIS/PISST/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
Fim:

    GetPIS = nv
    Set n = Nothing
End Function


Function GetCOFINS(ByVal node As IXMLDOMNode, ByVal intCampo As Integer)
'Caso a opção intCampo seja:
'1 = CST
'2 = Aliquota COFINS
'3 = Valor COFINS

    Dim strCampo    As String
    Select Case intCampo
        Case 1
            strCampo = "CST"
        Case 2
            strCampo = "pCOFINS"
        Case 3
            strCampo = "vCOFINS"
    End Select
    
    Dim n As IXMLDOMNode, nv
    Set n = node.SelectSingleNode("imposto/COFINS/COFINSAliq/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/COFINS/COFINSQtde/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/COFINS/COFINSNT/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/COFINS/COFINSOutr/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/COFINS/COFINSST/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
Fim:

    GetCOFINS = nv
    Set n = Nothing
End Function

Function GetIPI(ByVal node As IXMLDOMNode, ByVal intCampo As Integer)
'Caso a opção intCampo seja:
'1 = CST
'2 = Valor IPI

    Dim strCampo    As String
    Select Case intCampo
        Case 1
            strCampo = "CST"
        Case 2
            strCampo = "vIPI"
    End Select
    
    Dim n As IXMLDOMNode, nv
    Set n = node.SelectSingleNode("imposto/IPI/IPITrib/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
    
    Set n = node.SelectSingleNode("imposto/IPI/IPINT/" & strCampo)
    If Not n Is Nothing Then
        nv = n.nodeTypedValue
        GoTo Fim
    End If
        
Fim:

    GetIPI = nv
    Set n = Nothing
End Function

primeira macro gravada: 

Sub copiar_dados_para_leiaute()
'
' copiar_dados_para_leiaute Macro
'

    Application.ScreenUpdating = False
    Sheets("LerXml").Select
    Range("I3").Select
    Sheets("txt saída").Select
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "A"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "|"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "1.02"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "I"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "|"
    Range("C3").Select
    Sheets("LerXml").Select
    Range("I3").Select
    Selection.Copy
    Sheets("txt saída").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("D3").Select
    ActiveCell.FormulaR1C1 = "|"
    Range("E3").Select
    Sheets("LerXml").Select
    Range("J3").Select
    Selection.Copy
    Sheets("txt saída").Select
    ActiveSheet.Paste
    Range("F3").Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("G3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("H3").Select
    Sheets("LerXml").Select
    Range("K3").Select
    Selection.Copy
    Sheets("txt saída").Select
    ActiveSheet.Paste
    Range("I3").Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("J3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("K3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("L3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "UN"
    Range("M3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("N3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("O3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("P3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "UN"
    Range("Q3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("R3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("S3").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("A4").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "M"
    Range("B4").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "0"
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "|"
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "0"
    Sheets("LerXml").Select
    Range("I2").Select
    Sheets("txt saída").Select
    Range("A5").Select
    Application.ScreenUpdating = True
    MsgBox "Informações foram copiadas com sucesso!", vbInformation, "Aviso"
End Sub

segunda macro gravada: essa não precisa alterar, só coloquei o código para ficar completo o tópico

Sub começar_novamente()
'
' começar_novamente Macro
'

'
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
End Sub
 
Postado : 27/04/2018 4:51 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 

Executando essa macro gravada, obtive o preenchimento de 3 linhas.
Tentando imaginar uma lógica:
Você quer preencher sempre de 3 em 3 linhas.
Então a primeira vez começa na linha 2 e vai até a linha 4.
A segunda vez começa na linha 5 e vai até a linha 7.
E assim por diante.
Quando digo primeira vez, segunda vez, não é que você vai ficar executando a macro várias vezes.
Estou me referindo às voltas que serão feitas no laço de repetição.
Seria linha = 2, depois linha = 5, depois linha = 8 ...

Isso poderia ser feito da seguinte forma:


For linha = 2 to 200 step 3


Next linha

Step 3 significa que vai aumentar de 3 em 3.

Se for isso, confirme. Se não for, corrija o que estiver errado neste raciocínio.

Outra coisa que você não deixou claro:

Note que, no meu exemplo, vai apenas até 200.

Você não especificou quando essa repetição vai parar.

Por exemplo:

Quero fazer fazer essa repetição de 3 em 3 na planilha Consolidado enquanto houver linha preenchida na coluna A da planilha Dados.

Aí eu montaria um laço que, a cada linha preenchida da planilha Dados, eu preencheria 3 linhas na planilha Consolidado.

É necessário que você especifique essa parte.

 
Postado : 27/04/2018 5:24 am
 JNEXCEL
(@jnexcel)
Posts: 298
Reputable Member
Topic starter
 

vou tentar expressar o que preciso:

no link que postei existe uma pasta de trabalho do excel, essa pasta possui duas planilhas

1ª planilha LerXml

2ª planilha txt Saída (Planilha que estamos corrigindo o código vba)

na 1ª planilha LerXml, existe um botão IMPORTAR XML TESTE, nessa planilha LerXml, eu deixei exibido apenas três colunas:

Coluna I = Cod. Produto (vai receber o código do produto contido no xml de nfe)

Coluna j = Desc. Produto (vai receber a descrição do produto contida no xml de nfe)

Coluna k = NCM (vai receber a NCM do produto contida no xml de nfe)

Essa planilha está ok, não precisa de ajustes.

na 2ª planilha txt saída, eu tenho:

célula A1 = PRODUTO

célula B1 = sinal |

célula C1 = =CONT.SES(A:A;"A") para contar quantas vezes a letra é exibida na coluna A:A

botão Criar Leiaute txt

essa minha 2ª planilha é totalmente dependente da 1ª, pois eu preciso sempre
utilizar os dados contidos na 1ª.

meu exemplo é o que está no link "a forma que encontrei para gerar um txt no leiaute", porém se você ou qualquer outro
usuário tenha uma forma melhor eu aceito.

o processo é o seguinte:

entrada de dados = planilha LerXml

formato de saída dos dados

PRODUTO|1
A|1.02
I|2015|APARADOR||94033000|||UN|||UN|||
M|0|0

preciso que seja assim, pois do contrário o sistema da nota fiscal eletrônica não aceita.

no exemplo que postei, eu anexei um xml contendo 3 produtos, logo a saída do txt deverá ser assim:

PRODUTO|3
A|1.02
I|2015|APARADOR||94033000|||UN|||UN|||
M|0|0
A|1.02
I|2016|CACHEPÔ||94033000|||UN|||UN|||
M|0|0
A|1.02
I|2017|ARMÁRIO DE APOIO||94033000|||UN|||UN|||
M|0|0

Eu consigo fazer com o meu código rode apenas para o primeiro produto.

então, respondendo a sua pergunta.

a planilha txt saída deverá conter a mesma quantidade de itens do xml (xml importado na planilha LerXml)

 
Postado : 27/04/2018 6:53 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 
Sub copiar_dados_para_leiaute()
'
' copiar_dados_para_leiaute Macro
'
Dim ul As Long
Dim linha As Long
linha = 3
    Application.ScreenUpdating = False
Dim cl As Object

For Each cl In Sheets("txt saída").UsedRange.Cells

If cl.Row > 1 Then

cl.ClearContents

End If

Next cl


While Sheets("LerXml").Range("A" & linha).Value <> ""
  For ul = 1 To Sheets("txt saída").Rows.Count
  
  If Sheets("txt saída").Range("A" & ul).Value = "" Then
Exit For
 End If
 Next ul

Sheets("txt saída").Select
    Sheets("txt saída").Range("A" & ul).Select
    ActiveCell.FormulaR1C1 = "A"
    'Range("B2").Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "|"
    'Range("C2").Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "1.02"
    'Range("A3").Select
    ActiveCell.Offset(1, -2).Select
    ActiveCell.FormulaR1C1 = "I"
    'Range("B3").Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "|"
    'Range("C3").Select
    ActiveCell.Offset(0, 1).Select
    Sheets("LerXml").Select
    Range("I" & linha).Select
    Selection.Copy
    Sheets("txt saída").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    'Range("D3").Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "|"
    'Range("E3").Select
    ActiveCell.Offset(0, 1).Select
    Sheets("LerXml").Select
    'Range("J3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.Copy
    Sheets("txt saída").Select
    ActiveSheet.Paste
    'Range("F3").Select
    ActiveCell.Offset(0, 1).Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("G3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("H3").Select
    ActiveCell.Offset(0, 1).Select
    Sheets("LerXml").Select
    'Range("K3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.Copy
    Sheets("txt saída").Select
    ActiveSheet.Paste
    'Range("I3").Select
    ActiveCell.Offset(0, 1).Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("J3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("K3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("L3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "UN"
    'Range("M3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("N3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("O3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("P3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "UN"
    'Range("Q3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("R3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("S3").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("A4").Select
    ActiveCell.Offset(1, -18).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "M"
    'Range("B4").Select
    ActiveCell.Offset(0, 1).Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "|"
    'Range("C4").Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "0"
    'Range("D4").Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "|"
    'Range("E4").Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "0"
    'Sheets("LerXml").Select
    'Range("I2").Select
    'Sheets("txt saída").Select
    'Range("A5").Select
    linha = linha + 1
Wend
    Application.ScreenUpdating = True
    MsgBox "Informações foram copiadas com sucesso!", vbInformation, "Aviso"
End Sub
 
Postado : 27/04/2018 8:59 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 

Execute os códigos passo a passo, apertando F5, para você aprender como eles funcionam.

Eu acho que nesta linha ocorreu um erro de digitação:

Sheets("txt saída").Range("A" & ul + 1).Value = "I"

Deveria ser:

Sheets("txt saída").Range("A" & ul + 1).Value = "|"
Sub copiar_dados_para_leiaute_mais_rapido2()
    '
    ' copiar_dados_para_leiaute Macro
    '
    Dim ul As Long
    Dim linha As Long
    linha = 3
    Application.ScreenUpdating = False
    Dim cl As Object
    
    For Each cl In Sheets("txt saída").UsedRange.Cells
        
        If cl.Row > 1 Then
            
            cl.ClearContents
            
        End If
        
    Next cl
    
    
    While Sheets("LerXml").Range("A" & linha).Value <> ""
        For ul = 1 To Sheets("txt saída").Rows.Count
            
            If Sheets("txt saída").Range("A" & ul).Value = "" Then
                Exit For
            End If
        Next ul
        

        Sheets("txt saída").Range("A" & ul).Value = "A"
        Sheets("txt saída").Range("B" & ul).Value = "|"
        Sheets("txt saída").Range("C" & ul).Value = "1.02"
        Sheets("txt saída").Range("A" & ul + 1).Value = "I"
        Sheets("txt saída").Range("B" & ul + 1).Value = "|"
        Sheets("txt saída").Range("C" & ul + 1).Value = Sheets("LerXml").Range("I" & linha).Value
        Sheets("txt saída").Range("D" & ul + 1).Value = "|"
        Sheets("txt saída").Range("E" & ul + 1).Value = Sheets("LerXml").Range("J" & linha).Value
        Sheets("txt saída").Range("F" & ul + 1).Value = "|"
        Sheets("txt saída").Range("G" & ul + 1).Value = "|"
        Sheets("txt saída").Range("H" & ul + 1).Value = Sheets("LerXml").Range("K" & linha).Value
        Sheets("txt saída").Range("I" & ul + 1).Value = "|"
        Sheets("txt saída").Range("J" & ul + 1).Value = "|"
        Sheets("txt saída").Range("K" & ul + 1).Value = "|"
        Sheets("txt saída").Range("L" & ul + 1).Value = "UN"
        Sheets("txt saída").Range("M" & ul + 1).Value = "|"
        Sheets("txt saída").Range("N" & ul + 1).Value = "|"
        Sheets("txt saída").Range("O" & ul + 1).Value = "|"
        Sheets("txt saída").Range("P" & ul + 1).Value = "UN"
        Sheets("txt saída").Range("Q" & ul + 1).Value = "|"
        Sheets("txt saída").Range("R" & ul + 1).Value = "|"
        Sheets("txt saída").Range("S" & ul + 1).Value = "|"
        Sheets("txt saída").Range("A" & ul + 2).Value = "M"
        Sheets("txt saída").Range("B" & ul + 2).Value = "|"
        Sheets("txt saída").Range("C" & ul + 2).Value = "0"
        Sheets("txt saída").Range("D" & ul + 2).Value = "|"
        Sheets("txt saída").Range("E" & ul + 2).Value = "0"
        
        
        linha = linha + 1
    Wend
    Application.ScreenUpdating = True
    MsgBox "Informações foram copiadas com sucesso!", vbInformation, "Aviso"
End Sub

ou

Sub copiar_dados_para_leiaute_mais_rapido()
    '
    ' copiar_dados_para_leiaute Macro
    '
    Dim ul As Long
    Dim linha As Long
    linha = 3
    Application.ScreenUpdating = False
    Dim cl As Object
    
    For Each cl In Sheets("txt saída").UsedRange.Cells
        
        If cl.Row > 1 Then
            
            cl.ClearContents
            
        End If
        
    Next cl
    
    
    While Sheets("LerXml").Range("A" & linha).Value <> ""
        For ul = 1 To Sheets("txt saída").Rows.Count
            
            If Sheets("txt saída").Range("A" & ul).Value = "" Then
                Exit For
            End If
        Next ul
        
 
        Sheets("txt saída").Range("A" & ul).Value = "A"
        Sheets("txt saída").Range("B" & ul).Value = "|"
        Sheets("txt saída").Range("C" & ul).Value = "1.02"
        Sheets("txt saída").Range("A" & ul + 1).Value = "I"
        Sheets("txt saída").Range("B" & ul + 1).Value = "|"
        Sheets("txt saída").Range("C" & ul + 1).Value = Sheets("LerXml").Range("I" & linha).Value
        Sheets("txt saída").Range("D" & ul + 1).Value = "|"
        Sheets("txt saída").Range("E" & ul + 1).Value = Sheets("LerXml").Range("J" & linha).Value
        Sheets("txt saída").Range("F" & ul + 1).Value = "|"
        Sheets("txt saída").Range("G" & ul + 1).Value = "|"
        Sheets("txt saída").Range("F" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("G" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("H" & ul + 1).Value = Sheets("LerXml").Range("K" & linha).Value
        Sheets("txt saída").Range("I" & ul + 1).Value = "|"
        Sheets("txt saída").Range("J" & ul + 1).Value = "|"
        Sheets("txt saída").Range("I" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("J" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("K" & ul + 1).Value = "|"
        Sheets("txt saída").Range("K" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("L" & ul + 1).Value = "UN"
        Sheets("txt saída").Range("L" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("M" & ul + 1).Value = "|"
        Sheets("txt saída").Range("M" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("N" & ul + 1).Value = "|"
        Sheets("txt saída").Range("N" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("O" & ul + 1).Value = "|"
        Sheets("txt saída").Range("O" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("P" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("P" & ul + 1).Value = "UN"
        Sheets("txt saída").Range("Q" & ul + 1).Value = "|"
        Sheets("txt saída").Range("Q" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("R" & ul + 1).Value = "|"
        Sheets("txt saída").Range("R" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("S" & ul + 1).Value = "|"
        Sheets("txt saída").Range("S" & ul + 1).NumberFormat = "General"
        Sheets("txt saída").Range("A" & ul + 2).Value = "M"
        Sheets("txt saída").Range("A" & ul + 2).NumberFormat = "General"
        Sheets("txt saída").Range("B" & ul + 2).Value = "|"
        Sheets("txt saída").Range("B" & ul + 2).NumberFormat = "General"
        Sheets("txt saída").Range("C" & ul + 2).Value = "0"
        Sheets("txt saída").Range("C" & ul + 2).NumberFormat = "General"
        Sheets("txt saída").Range("D" & ul + 2).Value = "|"
        Sheets("txt saída").Range("D" & ul + 2).NumberFormat = "General"
        Sheets("txt saída").Range("E" & ul + 2).Value = "0"
        Sheets("txt saída").Range("E" & ul + 2).NumberFormat = "General"
        
        
        linha = linha + 1
    Wend
    Application.ScreenUpdating = True
    MsgBox "Informações foram copiadas com sucesso!", vbInformation, "Aviso"
End Sub
 
Postado : 27/04/2018 9:31 am
Forum Jump:
  Tópico Anterior
Próximo Tópico