Praticamente voglio copiare un foglio che contiene formule, immagini ecc in un foglio con solo valori e fin qui tutto bene.
Vorrei aggiungere alla macro la possibilità di copiare le celle unite come tali e non come celle singole e vorrei copiare anche i grafici. Questi due passaggi non sono riuscito ad aggiungere, molto probabilmente non sono stato in grado di fornire il prompt giusto.
allego la macro.
Naturalmente io sono partito da una macro molto più piccola e semplice, quelle che allego sono il risultato di un giorno di lavoro con chat GPT
questa è quella che funziona senza forzare la copia delle celle e dei grafici
Codice: Seleziona tutto
Sub CopiaValoriTestoConFormattazioneDaFoglioDinamico()
' Dichiarazione delle variabili
Dim oDocument As Object
Dim oSheetDati As Object
Dim oSheetNuovo As Object
Dim oCellaNomeOrigine As Object
Dim oCellaNomeDestinazione As Object
Dim nomeFoglioOrigine As String
Dim nomeFoglioDestinazione As String
Dim rangeDati As Object
Dim sourceCell As Object
Dim targetCell As Object
Dim i As Integer
Dim j As Integer
Dim oShape As Object
Dim targetPage As Object
Dim oDrawPage As Object
' Ottieni il documento attivo (il file Calc aperto)
oDocument = ThisComponent
' Ottieni il foglio attivo da cui prendere il nome del foglio di origine
oSheetDati = oDocument.CurrentController.ActiveSheet
' Ottieni il nome del foglio di origine dalla cella O1
oCellaNomeOrigine = oSheetDati.getCellRangeByName("O1")
nomeFoglioOrigine = oCellaNomeOrigine.getString()
' Ottieni il nome del foglio di destinazione dalla cella F1
oCellaNomeDestinazione = oSheetDati.getCellRangeByName("F1")
nomeFoglioDestinazione = oCellaNomeDestinazione.getString()
' Controlla se il foglio di origine esiste
On Error GoTo FoglioOrigineNonTrovato
oSheetDati = oDocument.Sheets.getByName(nomeFoglioOrigine)
' Controlla se il foglio con lo stesso nome esiste già
On Error GoTo CreaFoglio
oSheetNuovo = oDocument.Sheets.getByName(nomeFoglioDestinazione)
MsgBox "Un foglio con questo nome esiste già!"
Exit Sub
FoglioOrigineNonTrovato:
MsgBox "Il foglio di origine " & nomeFoglioOrigine & " non esiste."
Exit Sub
CreaFoglio:
' Crea un nuovo foglio con il nome specificato
oDocument.Sheets.insertNewByName(nomeFoglioDestinazione, oDocument.Sheets.getCount())
oSheetNuovo = oDocument.Sheets.getByName(nomeFoglioDestinazione)
' Copia le dimensioni delle colonne e delle righe
For i = 0 To 7 ' Per le colonne da A a H
oSheetNuovo.Columns(i).Width = oSheetDati.Columns(i).Width
Next i
For i = 0 To 104 ' Per le righe da 1 a 105
oSheetNuovo.Rows(i).Height = oSheetDati.Rows(i).Height
Next i
' Specifica il range dei dati da copiare (celle da A1 a H105)
rangeDati = oSheetDati.getCellRangeByName("A1:H105")
' Passa a copiare contenuti e formattazione
For i = 0 To rangeDati.Rows.getCount() - 1
For j = 0 To rangeDati.Columns.getCount() - 1
sourceCell = rangeDati.getCellByPosition(j, i)
targetCell = oSheetNuovo.getCellByPosition(j, i)
' Copia il contenuto della cella (valori, testo, formula)
If sourceCell.Type = com.sun.star.table.CellContentType.EMPTY Then
targetCell.clearContents(1023)
ElseIf sourceCell.Type = com.sun.star.table.CellContentType.VALUE Then
targetCell.Value = sourceCell.Value
ElseIf sourceCell.Type = com.sun.star.table.CellContentType.TEXT Then
targetCell.String = sourceCell.String
ElseIf sourceCell.Type = com.sun.star.table.CellContentType.FORMULA Then
If sourceCell.FormulaResultType = com.sun.star.table.CellContentType.TEXT Then
targetCell.String = sourceCell.String
ElseIf sourceCell.FormulaResultType = com.sun.star.table.CellContentType.VALUE Then
If sourceCell.Value = 0 Then
targetCell.clearContents(1023)
Else
targetCell.Value = sourceCell.Value
End If
End If
End If
' Copia la formattazione
targetCell.NumberFormat = sourceCell.NumberFormat
targetCell.TableBorder = sourceCell.TableBorder
Next j
Next i
' Copia le immagini
targetPage = oSheetNuovo.getDrawPage()
oDrawPage = oSheetDati.getDrawPage()
For i = 0 To oDrawPage.getCount() - 1
oShape = oDrawPage.getByIndex(i)
If oShape.supportsService("com.sun.star.drawing.GraphicObjectShape") Then
Dim newShape As Object
Set newShape = oDocument.createInstance("com.sun.star.drawing.GraphicObjectShape")
newShape.GraphicURL = oShape.GraphicURL
Dim oPoint As New com.sun.star.awt.Point
oPoint.X = oShape.Position.X
oPoint.Y = oShape.Position.Y
newShape.Position = oPoint
Dim oSize As New com.sun.star.awt.Size
oSize.Width = oShape.Size.Width
oSize.Height = oShape.Size.Height
newShape.Size = oSize
newShape.GraphicCrop = oShape.GraphicCrop
On Error Resume Next
newShape.Name = oShape.Name
newShape.ZOrder = oShape.ZOrder
newShape.Transparency = oShape.Transparency
newShape.GraphicColorMode = oShape.GraphicColorMode
On Error GoTo 0
targetPage.add(newShape)
End If
Next i
MsgBox "Dati, formattazione e immagini copiati con successo dal foglio " & nomeFoglioOrigine & " al foglio " & nomeFoglioDestinazione
End Sub
Codice: Seleziona tutto
Sub CopiaValoriTestoConFormattazioneDaFoglioDinamico()
' Dichiarazione delle variabili
Dim oDocument As Object
Dim oSheetDati As Object
Dim oSheetNuovo As Object
Dim oCellaNomeOrigine As Object
Dim oCellaNomeDestinazione As Object
Dim nomeFoglioOrigine As String
Dim nomeFoglioDestinazione As String
Dim rangeDati As Object
Dim sourceCell As Object
Dim targetCell As Object
Dim i As Integer
Dim j As Integer
Dim oShape As Object
Dim targetPage As Object
Dim oDrawPage As Object
Dim bIsMerged As Boolean
' Ottieni il documento attivo (il file Calc aperto)
oDocument = ThisComponent
' Ottieni il foglio attivo da cui prendere il nome del foglio di origine
oSheetDati = oDocument.CurrentController.ActiveSheet
' Ottieni il nome del foglio di origine dalla cella O1
oCellaNomeOrigine = oSheetDati.getCellRangeByName("O1")
nomeFoglioOrigine = oCellaNomeOrigine.getString()
' Ottieni il nome del foglio di destinazione dalla cella F1
oCellaNomeDestinazione = oSheetDati.getCellRangeByName("F1")
nomeFoglioDestinazione = oCellaNomeDestinazione.getString()
' Controlla se il foglio di origine esiste
On Error GoTo FoglioOrigineNonTrovato
oSheetDati = oDocument.Sheets.getByName(nomeFoglioOrigine)
' Controlla se il foglio con lo stesso nome esiste già
On Error GoTo CreaFoglio
oSheetNuovo = oDocument.Sheets.getByName(nomeFoglioDestinazione)
MsgBox "Un foglio con questo nome esiste già!"
Exit Sub
FoglioOrigineNonTrovato:
MsgBox "Il foglio di origine " & nomeFoglioOrigine & " non esiste."
Exit Sub
CreaFoglio:
' Crea un nuovo foglio con il nome specificato
oDocument.Sheets.insertNewByName(nomeFoglioDestinazione, oDocument.Sheets.getCount())
oSheetNuovo = oDocument.Sheets.getByName(nomeFoglioDestinazione)
' Copia le dimensioni delle colonne e delle righe
For i = 0 To 7 ' Per le colonne da A a H
oSheetNuovo.Columns(i).Width = oSheetDati.Columns(i).Width
Next i
For i = 0 To 104 ' Per le righe da 1 a 105
oSheetNuovo.Rows(i).Height = oSheetDati.Rows(i).Height
Next i
' Specifica il range dei dati da copiare (celle da A1 a H105)
rangeDati = oSheetDati.getCellRangeByName("A1:H105")
' Prima passa a copiare contenuti e formattazione
For i = 0 To rangeDati.Rows.getCount() - 1
For j = 0 To rangeDati.Columns.getCount() - 1
sourceCell = rangeDati.getCellByPosition(j, i)
targetCell = oSheetNuovo.getCellByPosition(j, i)
' Copia il contenuto della cella (valori, testo, formula)
If sourceCell.Type = com.sun.star.table.CellContentType.EMPTY Then
targetCell.clearContents(1023)
ElseIf sourceCell.Type = com.sun.star.table.CellContentType.VALUE Then
targetCell.Value = sourceCell.Value
ElseIf sourceCell.Type = com.sun.star.table.CellContentType.TEXT Then
targetCell.String = sourceCell.String
ElseIf sourceCell.Type = com.sun.star.table.CellContentType.FORMULA Then
If sourceCell.FormulaResultType = com.sun.star.table.CellContentType.TEXT Then
targetCell.String = sourceCell.String
ElseIf sourceCell.FormulaResultType = com.sun.star.table.CellContentType.VALUE Then
If sourceCell.Value = 0 Then
targetCell.clearContents(1023)
Else
targetCell.Value = sourceCell.Value
End If
End If
End If
' Copia la formattazione
targetCell.NumberFormat = sourceCell.NumberFormat
targetCell.TableBorder = sourceCell.TableBorder
Next j
Next i
' Secondo passa per le celle unite
For i = 0 To rangeDati.Rows.getCount() - 1
For j = 0 To rangeDati.Columns.getCount() - 1
sourceCell = rangeDati.getCellByPosition(j, i)
' Verifica se la cella è unita
On Error Resume Next
bIsMerged = sourceCell.IsMerged
On Error GoTo 0
If bIsMerged Then
' Ottieni il range delle celle unite
Dim mergedRange As Object
On Error Resume Next
Set mergedRange = sourceCell.getMergedRegion()
On Error GoTo 0
If Not IsNothing(mergedRange) Then
' Se getMergedRegion ha funzionato, usa il metodo standard
Dim targetMergeRange As Object
Set targetMergeRange = oSheetNuovo.getCellRangeByPosition( _
mergedRange.RangeAddress.StartColumn, _
mergedRange.RangeAddress.StartRow, _
mergedRange.RangeAddress.EndColumn, _
mergedRange.RangeAddress.EndRow)
targetMergeRange.merge(True)
End If
End If
Next j
Next i
' Copia le immagini
targetPage = oSheetNuovo.getDrawPage()
oDrawPage = oSheetDati.getDrawPage()
For i = 0 To oDrawPage.getCount() - 1
oShape = oDrawPage.getByIndex(i)
If oShape.supportsService("com.sun.star.drawing.GraphicObjectShape") Then
Dim newShape As Object
Set newShape = oDocument.createInstance("com.sun.star.drawing.GraphicObjectShape")
newShape.GraphicURL = oShape.GraphicURL
Dim oPoint As New com.sun.star.awt.Point
oPoint.X = oShape.Position.X
oPoint.Y = oShape.Position.Y
newShape.Position = oPoint
Dim oSize As New com.sun.star.awt.Size
oSize.Width = oShape.Size.Width
oSize.Height = oShape.Size.Height
newShape.Size = oSize
newShape.GraphicCrop = oShape.GraphicCrop
On Error Resume Next
newShape.Name = oShape.Name
newShape.ZOrder = oShape.ZOrder
newShape.Transparency = oShape.Transparency
newShape.GraphicColorMode = oShape.GraphicColorMode
On Error GoTo 0
targetPage.add(newShape)
End If
Next i
MsgBox "Dati, formattazione, celle unite e immagini copiati con successo dal foglio " & nomeFoglioOrigine & " al foglio " & nomeFoglioDestinazione
End Sub