Notifications
Clear all

Altar célula de referência no código

4 Posts
3 Usuários
0 Reactions
1,273 Visualizações
(@andremene)
Posts: 3
New Member
Topic starter
 

Bom dia a todos!

Tenho uma macro que importa alguns arquivos em CSV e coloca automaticamente em sequencia na planilha, eu copiei o código de outro tópico aqui no fórum e deu certo mas preciso de uma alteração que não estou sabendo fazer (tentei perguntar no tópico mas ninguém responde). O problema é que ela usa a coluna "A" como referência para colocar os novos valores e em alguns arquivos a coluna "A" vem vazia e isto faz com que ele sobrescreva as informações. Gostaria de alterar para que ele se referenciasse na coluna "B" para saber em qual linha inserir o arquivo sem sobrescrever o anterior pois a "B" sempre estará com alguma informação.

Segue código:

Sub Botão1_Clique()
Dim Pasta As String
Dim Arquivo As String
Dim LinInicial As Long
Dim LinFinal As Long

'Abre caixa de diálogo para selecionar a pasta onde estão
'os arquivos
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Pasta = .SelectedItems(1)
End With

Arquivo = Dir(Pasta & "*.csv")

While Arquivo <> ""

Workbooks.OpenText Filename:=Pasta & "" & Arquivo, _
DataType:=xlDelimited, Other:=True, OtherChar:=",", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))

'Linha inicial onde deve-se colocar o nome do arquivo
LinInicial = ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row
ActiveSheet.[A1].CurrentRegion.Copy _
ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0)

'Linha final onde deve-se colocar o nome do arquivo
LinFinal = ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row
ThisWorkbook.ActiveSheet.Cells(LinInicial, "F").Resize(LinFinal - LinInicial, 1).Value = Arquivo
ActiveWorkbook.Close False
Arquivo = Dir
DoEvents
Wend
MsgBox "FRS's Importadas Com Sucesso!"

End Sub

 
Postado : 21/09/2018 8:25 am
xlarruda
(@xlarruda)
Posts: 732
Honorable Member
 

Acredito que basta mudar a letra "A" dessa linha por "B"
De:
ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0)
por:
ThisWorkbook.ActiveSheet.Range("B" & Cells.Rows.Count).End(xlUp).Offset(1, 0)

Segue:

Sub Botão1_Clique()
Dim Pasta As String
Dim Arquivo As String
Dim LinInicial As Long
Dim LinFinal As Long

'Abre caixa de diálogo para selecionar a pasta onde estão
'os arquivos
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Pasta = .SelectedItems(1)
End With

Arquivo = Dir(Pasta & "*.csv")


While Arquivo <> ""

Workbooks.OpenText Filename:=Pasta & "" & Arquivo, _
DataType:=xlDelimited, Other:=True, OtherChar:=",", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))




'Linha inicial onde deve-se colocar o nome do arquivo
LinInicial = ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row
ActiveSheet.[A1].CurrentRegion.Copy _
ThisWorkbook.ActiveSheet.Range("B" & Cells.Rows.Count).End(xlUp).Offset(1, 0)

'Linha final onde deve-se colocar o nome do arquivo
LinFinal = ThisWorkbook.ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row
ThisWorkbook.ActiveSheet.Cells(LinInicial, "F").Resize(LinFinal - LinInicial, 1).Value = Arquivo
ActiveWorkbook.Close False
Arquivo = Dir
DoEvents
Wend
MsgBox "FRS's Importadas Com Sucesso!"


End Sub

___________________________________________________________________________________________
Se a resposta atendeu sua dúvida, por favor, clique no Gostei e marque o Tópico como [Resolvido].

Att.

André Arruda

 
Postado : 21/09/2018 8:34 am
(@andremene)
Posts: 3
New Member
Topic starter
 

Bom dia,

Obrigado pelo retorno.

Ao fazer essa alteração ele apresenta um erro de definição de aplicativo ou objeto e quando peço para Depurar ele indica a seguinte linha:

ThisWorkbook.ActiveSheet.Cells(LinInicial, "F").Resize(LinFinal - LinInicial, 1).Value = Arquivo

 
Postado : 22/09/2018 6:00 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Até onde podemos "ver" o erro apontado nada tem haver com a alteração proposta, e possível/provável já estar ocorrendo esse erro ou a alteração da proposta ter sido efetuad/aplicadaa de forma incorreta.
Nesse caso e preciso depurar a rotina "passo a passo" para tentar encontrar o erro

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 23/09/2018 4:50 am