Pergunte aqui
1

Copiar conteudo de um arquivo para outro via Macro

perguntadas 2018-08-23 04:25:21 +0100

imagem do gravatar de Marcelo Caldas

Caros Senhores,

Preciso fazer uma macro que verifique a condição "erro" na coluna D e copie o conteúdo de A#:D# para outro arquivo do Libre calc, renomeado com a data atual mais uma Tag que defino depois. Tipo 20180822_Pendencias.ods. Na minha planilha existem uns 500 registros. Isso diariamente.

Conheço muito pouco dessa Linguagem. Consegui procurando na net até copiar o que eu quero e jogar em outra planilha, mas não sei como nomeá-la e nem mantê-la fechada. vou martelando e dando jeito, mas desa vez eu desisti. hehe

editar alterar tag assinalar como ofensivo fechar mesclar Excluir

2 Respostas

3

respondidas 2018-08-24 02:55:36 +0100

imagem do gravatar de Grafeno

updated 2018-09-02 17:22:13 +0100

Boa noite,

Edição 01:

Para facilitar para todos, expandi o código para criar um documento do Calc oculto, copiar a planilha "Dados" do arquivo original, processar a cópia para ficar apenas os registros com status "ERRO", e salvar o novo arquivo no estilo 20180901_Pendencias.ods:

Código:

Sub Main
Dim oNovoDoc as Object
Dim sLocal as String, sTag as String, sData as String
Dim sArquivo as String, sURL as String 

   ' Preparar URL 
   sLocal = "D:\Temp\"
   sTag = "Pendencias"
   sData = Year(Date) & Right("00"&Month(Date),2) & Right("00"&Day(Date),2)
   sArquivo = sData & "_" & sTag & ".ods"
   sURL = convertToURL( sLocal & sArquivo )

   'Criar doc do Calc oculto'
   Dim Args(0) As New com.sun.star.beans.PropertyValue
   Args(0).Name = "Hidden"
   Args(0).Value = True
   oNovoDoc = StarDesktop.loadComponentFromURL( "private:factory/scalc", "_blank", 0, Args() )

   'Criar uma cópia da planilha Dados no novo arquivo'
   oNovoDoc.Sheets.importSheet( ThisComponent, "Dados", 0 )

   'Manipular diretamente a planilha cópia'
   oPlanCopia = oNovoDoc.Sheets(0) 'Ela foi inserida na posição 0'   
   For i =  UltimaLinha(oPlanCopia) to 1 Step -1
      oCel = oPlanCopia.getCellByPosition( 1, i )

      If oCel.String <> "ERRO" Then
         oPlanCopia.Rows.removeByIndex( i,1 )
      End If
   Next i

   'Salvarcomo'
   oNovoDoc.StoreAsURL( sURL, Array() )

   'Fechar'
   oNovoDoc.Close(1)

   MsgBox "Operação concluída com sucesso!"
End Sub

Function UltimaLinha( oPlan )
   oCursor = oPlan.createCursor
   oCursor.gotoEndOfUsedArea(True)
   UltimaLinha = oCursor.Rows.Count-1
End Function

Atte,

editar assinalar como ofensivo Excluir Link mais
0

respondidas 2018-08-27 04:33:44 +0100

imagem do gravatar de Marcelo Caldas

updated 2018-08-27 05:20:49 +0100

Ótimo, sua macro criou o arquivo perfeitamente, mas daí, não consegui encaixar ela na minha macro. Não sei se fica mais facil, mas vou colar minha macro na mensagem. Como falei, sou bem cru na coisa, uso muito a ferramenta de gravar macro pra conseguir alguma coisa. Eu mando ordenar as celulas primeiro pq fica mais rápido copiar o que eu quero. Se puder me ajudar de novo. Agradeço infinitamente.

Sub Pendencias()
Sheets("Processos").Select

Dim FileNo As Integer
Dim CurrentLine As String
Dim Filename As String
dim document   as object
dim dispatcher as object

document   = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
rem ----------------------------------------------------------------------
dim args1(10) as new com.sun.star.beans.PropertyValue
args1(0).Name = "ByRows"
args1(0).Value = true
args1(1).Name = "HasHeader"
args1(1).Value = true
args1(2).Name = "CaseSensitive"
args1(2).Value = false
args1(3).Name = "NaturalSort"
args1(3).Value = false
args1(4).Name = "IncludeAttribs"
args1(4).Value = true
args1(5).Name = "UserDefIndex"
args1(5).Value = 0
args1(6).Name = "Col1"
args1(6).Value = 4
args1(7).Name = "Ascending1"
args1(7).Value = true
args1(8).Name = "Col2"
args1(8).Value = 4
args1(9).Name = "Ascending2"
args1(9).Value = false
args1(10).Name = "IncludeComments"
args1(10).Value = false

dispatcher.executeDispatch(document, ".uno:DataSort", "", 0, args1())

Sheets("Pendencias").Select

Range("A1:K2000").Select
Selection.ClearContents

Sheets("Processos").Select

Range("AO" & 1048410).Select
ActiveCell.FormulaR1C1 = "= CONT.SE(D2:D6000;""ERRO"")"
Contador = Range("AO" & 1048410)
Range("AO" & 1048410).Select
Selection.ClearContents

Range("A" & 1).Select
ActiveSheet.Range(Cells(1, 1), Cells(contador, 4)).Select
Selection.Copy

Sheets("Pendencias").Select

Range("a" & 1).Select = p2
ActiveSheet.Paste

dispatcher.executeDispatch(document, ".uno:JumpToTable", "", 0, args1())

rem ----------------------------------------------------------------------
dim args2(2) as new com.sun.star.beans.PropertyValue
args2(0).Name = "DocName"
args2(0).Value = ""
args2(1).Name = "Index"
args2(1).Value = 32767
args2(2).Name = "Copy"
args2(2).Value = true
dispatcher.executeDispatch(document, ".uno:Move", "", 0, args2())

End Sub
editar assinalar como ofensivo Excluir Link mais

Comentários

Eu tambem estou tentando fazer a mesma coisa mas não estou conseguindo

imagem do gravatar de joaorochajjoaorochaj ( 2018-08-31 05:10:47 +0100 )editar
Login/Registrar para responder

Ferramentas de perguntas

1 seguidor

Estatísticas

Perguntadas: 2018-08-23 04:25:21 +0100

Lidas: 65 vezes

Última atualização: Sep 02