Hola buen día a todos!
Me gustaría solicitar su ayuda para saber cuál sería el código equivalente de LibreOffice Basic para poder realizar esta tarea:
- Se almacenaran en un directorio un archivo Destino y varios archivos de Excel que servirían como Origen
- Cada archivo de Excel origen tendrá varias columnas por hoja y varias hojas por libro
- Copiar el contenido de algunas columnas de las diferentes hojas de los archivos Origen al archivo Destino
- Separar en hojas en el archivo Destino el contenido de las columnas seleccionadas en las hojas de los archivos Origen
Tengo algunos codigos en VBA de Excel pero quiero trasladarlo a LibreOffice.
VBA Code:
Sub extraerDatosOtroLibro()
Dim wbLibroOrigen As Workbook
Dim wsHojaOrigen As Worksheet
Dim wbLibroDestino As Workbook
Dim wsHojaDestino As Worksheet
Dim Ruta As String
Ruta = "E:\Documents\Excel\RVTools_tvdellsfesa01.xlsx"
'Datos destino
Set wbLibroDestino = Workbooks(ThisWorkbook.Name)
Set wsHojaDestino = wbLibroDestino.Worksheets("Servidor Virtual")
'Datos origen
Set wbLibroOrigen = Workbooks.Open(Ruta)
Set wsHojaOrigen = wbLibroOrigen.Worksheets("vInfo")
uFila = wsHojaOrigen.Range("A" & Rows.Count).End(xlUp).Row
wsHojaOrigen.Range("A2:BJ" & uFila).Copy Destination:=wsHojaDestino.Range("A2")
Workbooks(wbLibroOrigen.Name).Close SaveChanges:=False
End Sub
El siguiente código hace lo mismo, es decir extrae la información pero de varios libros de Excel excepto que si los libros origen tienen varias hojas con múltiples filas y columnas, no se trae todo ni tampoco el código permite extraer información de columnas específicas.
VBA Code:
Option Explicit
Dim nArchivo As Integer, Conteo As Integer, i As Integer, j As Integer, n As Integer
Sub ImportarData()
Call ContarArchivos
Application.ScreenUpdating = False
Dim WorkBookOrigen As Workbook
Dim wsOrigen As Excel.Worksheet, _
wsDestino As Excel.Worksheet, _
rngOrigen As Excel.Range, _
rngDestino As Excel.Range, _
NombreArchivo As String, _
Carpeta As String
Carpeta = ActiveWorkbook.Path & "\"
nArchivo = 1
NombreArchivo = Dir(Carpeta & "RVTools_" & "*.xl*")
Do While Len(NombreArchivo) > 0
Set WorkBookOrigen = Workbooks.Open(Carpeta & NombreArchivo)
NombreArchivo = Dir()
ThisWorkbook.Activate
Set wsOrigen = WorkBookOrigen.Worksheets(1)
Set wsDestino = Worksheets(1)
Const celdaOrigen = "A2"
Set rngOrigen = wsOrigen.Range(celdaOrigen)
wsOrigen.Activate
rngOrigen.Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Errores:
If Err.Number = 1004 Then
wsOrigen.Activate
rngOrigen.Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
End If
For n = 1 To 1
wsDestino.Activate
On Error GoTo Errores
wsDestino.Cells(Columns.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Next n
Application.CutCopyMode = False
WorkBookOrigen.Save
WorkBookOrigen.Close
nArchivo = nArchivo + 1
Call Progreso
Loop
j = nArchivo - 1
Application.ScreenUpdating = True
MsgBox j & " Archivos procesados"
End Sub
Public Sub Progreso()
Dim Contador As Integer
Dim Maximo As Integer
Dim Mitiempo As Double
Maximo = nArchivo - 1
For Contador = 1 To Maximo Step 1
Mitiempo = Timer
Do
Loop While Timer - Mitiempo < 0.02
Application.StatusBar = "Progreso: " & Maximo & _
" de " & i & " (" & Format(Maximo / i, "Percent") & ")"
DoEvents
Next Contador
Application.StatusBar = False
End Sub
Public Sub ContarArchivos()
Dim cNombreArchivo, cCarpeta As String
cCarpeta = ActiveWorkbook.Path & "\"
Conteo = 1
cNombreArchivo = Dir(cCarpeta & "RVTools_" & "*.xl*")
Do While Len(cNombreArchivo) > 0
cNombreArchivo = Dir()
Conteo = Conteo + 1
Loop
i = Conteo - 1
End Sub
El siguiente código supuestamente busca dentro del directorio donde tenemos el archivo destino, todos los archivos con extensión .xlsx y copia el contenido de todas las hojas de excel contenidas en dichos archivos origen copiandolos al destino. Sin embargo de nuevo no permite realizar el copiado sólo de columnas específicas de cada una de las hojas
VBA Code:
'variable de tipo texto para almacenar el directorio
Dim directorio As String
'variable de tipo texto para almacenar el fichero actual
Dim fichero As String
'variable de tipo texto para almacenar el nombre del libro de Excel donde importar las hojas
Dim ficherodondeimportar As String
'variable de tipo "hoja de excel" para almacenar la hoja actual del fichero actual
Dim hoja As Worksheet
'variable de tipo entero para almacenar las hojas que tengo en el libro donde quiero importar el resto de hojas
Dim totalhojas As Integer
'le doy un valor a la variable directorio con el directorio donde estan el resto de libros de excel
directorio = "E:\Documents\Excel"
'le doy un valor al libro donde quiero importar todas las hojas del resto de libros
ficherodondeimportar = "importar-hojas.xlsm"
'le doy un valor a la variable fichero con el primer libro de excel que esta en el directorio
fichero = Dir(directorio & "*.xls")
'deshabilitamos las actualizaciones de pantalla y alertas para que el usuario no note que estamos abriendo libros en este proceso
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'mientras exista un nuevo libro de excel en el directorio
Do While fichero <> ""
'abrimos el libro de excel
Workbooks.Open (directorio & fichero)
'por cada hoja dentro del libro
For Each hoja in Workbooks(fichero).Worksheets
'obtenemo el numero de hojas de nuestro libro (donde queremos importar todo)
totalhojas = Workbooks(ficherodondeimportar).Worksheets.Count
'copiamos todo el contenido del libro que estamos abriendo en nuestro libro al final de todas las hojas
Workbooks(fichero).Worksheets(hoja.Name).Copy after:=Workbooks(ficherodondeimportar).Worksheets(totalhojas)
Next hoja
'cerramos el libro de excel actual
Workbooks(fichero).Close
' le doy un nuevo valir a la variable fichero para tomar el proximo libro del directorio
fichero = Dir()
Loop
'le doy el valor "true" a las varialbles de actualizacion de pantalla y alertas para que se muestren las nuevas hojas y los cambios en el libro donde se importo todo.
Application.ScreenUpdating = True
Application.DisplayAlerts = True
El código que llevo hasta el momento lo único que hace es abrir el archivo origen pero de ahí no sé como poder copiar las celdas hacia el archivo destino.
LibO Basic code:
REM ***** BASIC *****
Sub abrirotrolibro()
' Desde un documento Calc abre otro documento Calc existente y lo cierra.
Dim sRuta As String, oHoja As Object, mArg()
' Abro el libro donde quiero buscar el valor
sRuta = ConvertToUrl( "Ruta_del_archivo" )
oHoja = StarDesktop.loadComponentFromURL( _
sRuta, "_blank", 0, mArg() )
' Cierro el libro que acabo de abrir
' oHoja.close(True)
End Sub
¿Alguien sería tan amable de apoyarme con esta duda por favor?
Por acá encontré otro código que al parecer hace lo que estoy buscando sin embargo cuando lo ejecuto, no me copia nada al archivo destino, las celdas están en blanco, no sé si tenga que ver que el código hace eso. ¿Alguien que me pueda iluminar por favor?
LibO Basic code:
Sub rangecopy
Dim oDocA As Object, oDocB As Object, oSheetA As Object, Dummy(), oRangeA as object, targetcell as object
oDispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oDocA = ThisComponent
oFrameA = oDocA.CurrentController.Frame
oSheetA = oDocA.getSheets.getByIndex(0)
oRangeA = oSheetA.getCellRangeByName("A2:A37")
oDocA.CurrentController.Select(oRangeA)
oDispatcher.executeDispatch(oFrameA, ".uno:Copy", "", 0, Dummy())
oDocB = StarDesktop.loadComponentFromURL ("file:///Documents/Calc/archivo.xlsx", "_blank",0, Dummy() )
oSheetB = oDocB.getSheets.getByIndex(0)
c = oSheetB.createCursor
c.gotoEndOfUsedArea(false)
LastRow = c.RangeAddress.EndRow +1
targetcell= oSheetB.getCellByPosition(0,LastRow)
oDocB.CurrentController.Select(targetcell)
oFrameB = oDocB.CurrentController.Frame
oDispatcher.executeDispatch(oFrameB, ".uno:Paste", "", 0, Dummy())
oDocB.Store
oDocB.close(true)
End Sub
Variantes del código anterior en Portugués.
LibO Basic code:
Sub TransferirDados2
Dim oDoc As Object, oPlanOrigem As Object, oDocDestino as Object, oPlanDestino As Object
Dim sEndereco As String, sCol As String, sLin As String, sUrl As String
Dim iLin As Integer
Dim mArg(0) As New com.sun.star.beans.PropertyValue
'Obter a planilhas de origem
oDoc = ThisComponent
oPlanOrigem = oDoc.Sheets.getByName( "Planilha2" )
' Pegar o Endereço em B1 na planilha de origem
sEndereco = oPlanOrigem.getCellRangeByName( "B1" ).String
' Pegar a coluna e a linha definidas no endereço
sCol = Left( sEndereco,1 )
sLin = Mid( sEndereco,2,Len( sEndereco ) )
'Verificar se é um endereço válido
If Ucase( sCol ) <> "A" Or Not IsNumeric( sLin ) Then
MsgBox "Por favor, forneça um endereço correto.", 16, "Erro"
Exit Sub
End If
'Abrir o arquivo destino como oculto e obter a planilha de destino
mArg(0).Name = "Hidden"
mArg(0).Value = True
sUrl = convertToUrl("/home/grafeno/Área de Trabalho/Teste/Dados.ods") '<<< Caminho do arquivo destino
' No windows o caminho poderia ser, por exemplo, "D:\Teste\Dados.ods"
oDocDestino = StarDesktop.loadComponentFromURL( sUrl, "_blank", 0, mArg() )
oPlanDestino = oDocDestino.Sheets.getByName( "Planilha1" )
' Transferir os valores
iLin = cInt( sLin ) - 1 ' Menos 1 porque a posição das células começa com 0.
oPlanDestino.getCellByPosition( 0,iLin ).String = Ucase(sEndereco)
oPlanDestino.getCellByPosition( 1,iLin ).String = oPlanOrigem.getCellRangeByName( "B2" ).String
oPlanDestino.getCellByPosition( 2,iLin ).Value = oPlanOrigem.getCellRangeByName( "B3" ).Value
'Salvar e fechar o arquivo destino
oDocDestino.Store
oDocDestino.close(true)
' Limpar o conteúdo do intervalo B1:B3
' Argumentos do método clearContents:
' -> 1 para apagar valores
' -> 4 para apagar strings (texto)
' --> 1 + 4 = 5 apaga valores + string
oPlanOrigem.getCellRangeByName( "B1:B3" ).clearContents( 5 )
End Sub
Con Dispatcher y también en Portugués.
LibO Basic code:
Sub rangecopy
REM define os objetos
Dim oDocA, oDocB, oSheetA As Object, Dummy(), oRangeA, targetcell as object
REM define o dispatcher
oDispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
REM Documento A é o documento de origem, onde sua planilha está aberta
oDocA = ThisComponent
REM Frame A é o frame do documento de origem
oFrameA = oDocA.CurrentController.Frame
REM Planilha A é a primeira planilha, obtida aqui pelo índice zero, mas poderia ser também getByName("Planilha1")
oSheetA = oDocA.getSheets.getByIndex(0)
REM Range A é o intervalo de interesse
oRangeA = oSheetA.getCellRangeByName("C56:J56")
REM Ativa a seleção do intervalo Range A
oDocA.CurrentController.Select(oRangeA)
REM Invoca o despachador para o comando de cópia
oDispatcher.executeDispatch(oFrameA, ".uno:Copy", "", 0, Dummy())
REM
REM Define o arquivo de destino. Troque "file://" pelo arquivo certo
REM
oDocB = StarDesktop.loadComponentFromURL ("file:///D:/DATI/prova/invoicelog.ods", "_blank",0, Dummy() )
REM obtém a planilha 0 do arquivo de destino. pode usar também getByName("Planilha1")
oSheetB = oDocB.getSheets.getByIndex(0)
REM define a célula de destino. Pode ser também .getCellRangeByName("A1")
targetcell= oSheetB.getCellByPosition(0,0)
REM seleciona a célula de destino
oDocB.CurrentController.Select(targetcell)
REM define o frame de destino
oFrameB = oDocB.CurrentController.Frame
REM despacha a colagem
oDispatcher.executeDispatch(oFrameB, ".uno:Paste", "", 0, Dummy())
REM fecha o arquivo B
oDocB.Store
oDocB.close(true)
End Sub