Modifica file xls da access per formattazione

Anonimo

Ciao,

ho questo problema: devo formattare un file xls in base a delle regole.

Il mio codice non mi dà problemi: la modifica viene effettuata con successo.

Il problema è che rimane aperto il processo Excel nel task manager; quindi se rilancio la medesima funzione mi viene segnalato un errore: errore di run time '1004': metodo 'cells' dell'oggetto '_Global' non riuscito

Il codice che uso è questo:

Private Sub modificaLayOutFile_LUN()

Dim row As Integer

Dim lune as string

Dim saba as string

Dim nomeFileSalvato as string

lune = Year(txtDataLun) & "." & Month(txtDataLun) & "." & Day(txtDataLun)

saba = Year(txtDataSab) & "." & Month(txtDataSab) & "." & Day(txtDataSab)

nomeFileSalvato = "c:\pianificazione\settimana_" & lune & "_" & saba & ".xlsx"

Dim oBook As Object

Dim oSheet As Object

Dim oExcel As Object

Set oExcel = CreateObject("Excel.Application")

Set oBook = oExcel.Workbooks.Open(nomeFileSalvato)

'---------------------------------------------------

' AGISCO SUL PRIMO FOGLIO: LUNEDI'

'---------------------------------------------------

Set oSheet = oBook.Worksheets(1)

row = 2

'---------------------------------------------------

' Loop per modifica del file

'---------------------------------------------------

Do Until Cells(row, 7).Value = ""

'-----------------------------------------------------------

' Celle con A

'-----------------------------------------------------------

If Cells(row, 7).Value = "A" Then

Range(Cells(row, 7), Cells(row, 7)).Select

Selection.Font.Bold = True 'GRASSETTO

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.Color = RGB(255, 255, 0) 'giallo carico

.TintAndShade = 0

.PatternTintAndShade = 0

End With

With Selection

.HorizontalAlignment = xlCenter 'centrato

End With

End If

row = row + 1

Loop

oBook.Save

oBook.Close True

oExcel.Quit

End Sub

Grazie

Francesco

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

ciao Francesco,

testa questa routine :

Private Sub test()

On Error GoTo errorHandler

Dim lune As String

Dim saba As String

Dim Rng As Object ' Excel.Range

Dim oBook As Object ' Excel.WorkBook

Dim oSheet As Object ' Excel.WorkSheet

Dim oExcel As Object ' Excel.Application

Dim nomeFileSalvato As String

Dim lngLastRow As Long

Const strClass As String = "Excel.Application"

'lune = Year(txtDataLun) & "." & Month(txtDataLun) & "." & Day(txtDataLun)

'saba = Year(txtDataSab) & "." & Month(txtDataSab) & "." & Day(txtDataSab)

' prova a sostituire le istruzioni di cui sopra come segue :

'lune =format$(txtDataLun,"yyyy.m.d")

'saba=format$(txtDataSab,"yyyy.m.d")

nomeFileSalvato = "c:\pianificazione\settimana_" & lune & "_" & saba & ".xlsx"

On Error Resume Next

Set oExcel = GetObject(, strClass)

If Err.Number = 429 Then

Set oExcel = CreateObject(strClass)

End If

On Error GoTo 0

Set oBook = oExcel.Workbooks.Open(nomeFileSalvato)

For Each oSheet In oBook.sheets

On Error Resume Next

lngLastRow = LastRow(oSheet)

With oSheet

Set Rng = .Range("G2:AA" & lngLastRow)

Rng.FormatConditions.Delete

End With

On Error GoTo 0

Dim cond1 As Object, cond2 As Object, cond3 As Object

Dim cond4 As Object, cond5 As Object, cond6 As Object

Dim cond7 As Object, cond8 As Object, cond9 As Object

Dim cond10 As Object, cond11 As Object, cond12 As Object

Dim cond13 As Object, cond14 As Object, cond15 As Object

Dim cond16 As Object, cond17 As Object, cond18 As Object

With Rng.FormatConditions

Set cond1 = .Add(1, 3, "A")

Set cond2 = .Add(1, 3, "X")

Set cond3 = .Add(1, 3, "2")

Set cond4 = .Add(1, 3, "R")

Set cond5 = .Add(1, 3, "S")

Set cond6 = .Add(1, 3, "T")

Set cond7 = .Add(1, 3, "O")

Set cond8 = .Add(1, 3, "-")

Set cond9 = .Add(1, 3, "M")

Set cond10 = .Add(1, 3, "C")

Set cond11 = .Add(1, 3, "F")

Set cond12 = .Add(1, 3, "MR")

Set cond13 = .Add(1, 3, "SS")

Set cond14 = .Add(1, 3, "TP")

Set cond15 = .Add(1, 3, "PT")

Set cond16 = .Add(1, 3, "RO")

Set cond17 = .Add(1, 3, "FR")

Set cond18 = .Add(1, 3, "SR")

End With

With cond1

.Interior.Color = 65535 ' giallo

.Font.Color = 0 ' nero

End With

With cond2

.Interior.Color = 255 ' Rosso

.Font.Color = 16777215 ' bianco

End With

With cond3

.Interior.Color = 15631086 ' viola

.Font.Color = 0 ' nero

End With

With cond4

.Interior.Color = 8388352 ' verde

.Font.Color = 0 ' nero

End With

With cond5

.Interior.Color = 5219839 ' marrone chiaro

.Font.Color = 0 ' nero

End With

With cond6

.Interior.Color = 9445584 ' viola

.Font.Color = 16777215 ' bianco

End With

With cond7

.Interior.Color = 2841227 ' marrone scuro

.Font.Color = 16777215 ' bianco

End With

With cond8

.Interior.Color = 15453831 ' azzurro

.Font.Color = 0 ' nero

End With

With cond9

.Interior.Color = 0 ' nero

.Font.Color = 16777215 ' bianco

End With

With cond10

.Interior.Color = &H808080 ' grigio

.Font.Color = &H0 ' nero

End With

With cond11

.Interior.Color = 4557568 ' verde acceso

.Font.Color = 0 ' nero

End With

With cond12

.Interior.Color = 7794176 ' verdino

.Font.Color = 16777215 ' bianco

End With

With cond13

.Interior.Color = 14772544 ' Navy

.Font.Color = 16777215 ' bianco

End With

With cond14

.Interior.Color = 13224397 ' silver

.Font.Color = 9445584 ' purple

End With

With cond15

.Interior.Color = 16448255 ' grigio

.Font.Color = 9445584 ' purple

End With

With cond16

.Interior.Color = 4356590 ' marron

.Font.Color = 9445584 ' purple

End With

With cond17

.Interior.Color = 3706510 ' Oliva

.Font.Color = 9445584 ' purple

End With

With cond18

.Interior.Color = 65280 ' giallo/verde

.Font.Color = 9445584 ' purple

End With

With oExcel

.displayAlerts = False

oBook.Close SaveChanges:=True _

, FileName:=nomeFileSalvato

.displayAlerts = True

End With

VBA.MsgBox prompt:="Ho finito.", _

buttons:=vbInformation + vbOKOnly, _

title:="Info"

exitErrorHandler:

Set cond1 = Nothing

Set cond2 = Nothing

Set cond3 = Nothing

Set cond4 = Nothing

Set cond5 = Nothing

Set cond6 = Nothing

Set cond7 = Nothing

Set cond8 = Nothing

Set cond9 = Nothing

Set cond10 = Nothing

Set cond11 = Nothing

Set cond12 = Nothing

Set cond13 = Nothing

Set cond14 = Nothing

Set cond15 = Nothing

Set cond16 = Nothing

Set cond17 = Nothing

Set cond18 = Nothing

Set oSheet = Nothing

Set oBook = Nothing

oExcel.Quit

Set oExcel = Nothing

Exit Sub

errorHandler:

With Err

MsgBox "ERR#" & CStr(.Number) _

& vbNewLine & .Description _

, vbOKOnly Or vbCritical

End With

Resume exitErrorHandler

End Sub

ciao, Sandro.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

ciao Francesco,

prova a fornire qualche dettaglio specifico su condizioni/valori da verificare in base alla formattazione da applicare e vediamo come meglio procedere...

Ciao, Sandro.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

ciao Francesco,

[…]

ho provato con le tue modifiche ed ora è tutto ok!

Grazie!!!!!!

[…]

bene, ho preferito rivedere tutta una serie di aspetti.

Il loop e' un vincolo per valutare il valore contenuto nella cella, ma con il ciclo for … each l'esecuzione e' piu' efficiente/efficace, come in pratica nella totalita' dei casi in cui si vede ciclare una collection, nativa o customizzata di oggetti.

Nota bene tra il resto anche questa stralcio di codice :

On Error Resume Next

Set oExcel = GetObject(, strClass)

If Err.Number = 429 Then

Set oExcel = CreateObject(strClass)

End If

On Error GoTo 0

Quando devi riferirti a istanze degli altri applicativi facenti parte la suite office da Access o dagli altri ( a parte Access), e' sempre bene valutare se c'e' gia' un'instanza attiva per quell'applicativo, e solo se non c'e' accenderne una....per come procedevi ad ogni esecuizone accendevi tout court un"istanza nuova :-)

In realta' le righe di cui sopra andrebbero ulteriormente implementate per rendere rigorosa e robusta la logica teste' spiegata, per ora restiamo sul semplice...! ;-)

[…]

? Mi spiego: io dovrei formattare più fogli e più colonne a seconda del loro valore… quindi dovrei replicare quello che hai fatto tu ma x volte

[…]

cosa cambia nel caso in cui la stessa routine debba essere applicata a piu' workbooks?

Ovviamente il fatto di non volere aprire manualmente ( credo ) ogni singolo workbook ed il range di riferimento qualora non sia sempre quello che hai indicato nel tuo primo post.

Assumendo per ora lo scenario in cui la colonna da formattare sia sempre la stessa, valuta un fileDialog per selezionare tutti i workbooks a cui devi applicare la formattazione indicata, memorizza il relativo path in un array e "passa" in loop l'apertura e la formattazione per ogni path che corrisponde a un file di xls contenuto nell'array.

Spero sia chiaro.

[…]

PS: Cosa intendi quando dici che la sto testando senza access?

[…]

mancavano dal mio punto di vista i riferimenti agli oggetti di Excel, da qui l'osservazione.

[…]

Scusa la mia ignoranza...

[…]

tranqui, siamo qui per darci una mano l'un l'altro.

Facci sapere.

Ciao, Sandro.

0 commenti

17 risposte aggiuntive

Anonimo

2019-06-07T07:18:35+00:00

ciao Francesco,

da me come segue nessuna istanza appesa, ho rivisto un po' di cose...dal mio punto di vista la routine che hai mostrato la stai testando non con Access.

La funzione LastRow è di Norman David Jones.

Option Compare Database

Option Explicit

Private Sub modificaLayOutFile_LUN()

On Error GoTo errorHandler

Dim lune As String

Dim saba As String

Dim Rng             As Object ' Excel.Range

Dim oBook           As Object ' Excel.WorkBook

Dim oSheet          As Object ' Excel.WorkSheet

Dim oExcel          As Object ' Excel.application

Dim FoundCells      As Object ' Excel.Range

Dim Cell            As Object

Dim nomeFileSalvato As String

Dim lngLastRow      As Long

Const strClass      As String = "Excel.Application"

lune = Year(txtDataLun) & "." & Month(txtDataLun) & "." & Day(txtDataLun)

saba = Year(txtDataSab) & "." & Month(txtDataSab) & "." & Day(txtDataSab)

' prova a sostituire le istruzioni di cui sopra come segue :

'lune =format$(txtDataLun,"yyyy.m.d")

'saba=format$(txtDataSab,"yyyy.m.d")

nomeFileSalvato = "c:\pianificazione\settimana_" & lune & "_" & saba & ".xlsx"

On Error Resume Next

Set oExcel = GetObject(, strClass)

If Err.Number = 429 Then

    Set oExcel = CreateObject(strClass)

End If

On Error GoTo 0

Set oBook = oExcel.Workbooks.Open(nomeFileSalvato)



'---------------------------------------------------

' AGISCO SUL PRIMO FOGLIO: LUNEDI'

'---------------------------------------------------

   Set oSheet = oBook.Worksheets(1)

   'row = 2

'-----------

    On Error Resume Next

    lngLastRow = LastRow(oSheet)



    With oSheet

        Set Rng = .Range(oSheet.Cells(2, 7), .Cells(lngLastRow, 7))

    End With



    Set Rng = Rng.SpecialCells(2, 2) 'xlConstants, xlTextValues

    If Rng Is Nothing Then Exit Sub

    On Error GoTo 0



    For Each Cell In Rng

        If Cell.Value = "A" Then

            If FoundCells Is Nothing Then

                Set FoundCells = Cell

            Else

                Set FoundCells = oExcel.Union(FoundCells, Cell)

            End If

        End If

     Next



     With FoundCells

       .Font.Bold = True

       .HorizontalAlignment = -4108

     End With



     With FoundCells.Interior

             .Pattern = 1

             .PatternColorIndex = -4105 ' xlAutomatic

             .Color = RGB(255, 255, 0) 'giallo carico

             .TintAndShade = 0

             .PatternTintAndShade = 0

     End With



     With oExcel

         .displayAlerts = False

         oBook.Close SaveChanges:=True _

              , FileName:=nomeFileSalvato

        .displayAlerts = True

     End With



     VBA.MsgBox prompt:="Ho finito.", _

                buttons:=vbInformation + vbOKOnly, _

                title:="Info"





exitErrorHandler:

Set FoundCells = Nothing

Set Cell = Nothing

Set oSheet = Nothing

Set oBook = Nothing

oExcel.Quit

Set oExcel = Nothing

    Exit Sub

errorHandler:

    With Err

            MsgBox "ERR#" & CStr(.Number) _

                & vbNewLine & .Description _

                , vbOKOnly Or vbCritical

     End With

     Resume exitErrorHandler

End Sub

    Public Function LastRow(SH As Object, _

                            Optional Rng As Object)

   ' Norman David Jones's function



    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next



    'LastRow = Rng.Find(What:="*", _

    '                   after:=Rng.Cells(1), _

    '                   Lookat:=xlPart, _

    '                   LookIn:=xlFormulas, _

    '                   SearchOrder:=xlByRows, _

    '                   SearchDirection:=xlPrevious, _

    '                   MatchCase:=False).Row

     LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=2, _

                       LookIn:=-4123, _

                       SearchOrder:=1, _

                       SearchDirection:=2, _

                       MatchCase:=False).row

    On Error GoTo 0

End Function

Facci sapere.

Ciao, Sandro.

ps. vedi anche parte in grassetto.

Ciao Sandro,

ho provato con le tue modifiche ed ora è tutto ok!

Grazie!!!!!!

Puoi spiegarmi un secondo la logica delle modifiche? Mi spiego: io dovrei formattare più fogli e più colonne a seconda del loro valore… quindi dovrei replicare quello che hai fatto tu ma x volte

Scusa la mia ignoranza...

PS: Cosa intendi quando dici che la sto testando senza access?
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2019-06-06T20:02:36+00:00

ciao Francesco,

da me come segue nessuna istanza appesa, ho rivisto un po' di cose...dal mio punto di vista la routine che hai mostrato la stai testando non con Access.

La funzione LastRow è di Norman David Jones.

Option Compare Database

Option Explicit

Private Sub modificaLayOutFile_LUN()

On Error GoTo errorHandler

Dim lune As String

Dim saba As String

Dim Rng             As Object ' Excel.Range

Dim oBook           As Object ' Excel.WorkBook

Dim oSheet          As Object ' Excel.WorkSheet

Dim oExcel          As Object ' Excel.application

Dim FoundCells      As Object ' Excel.Range

Dim Cell            As Object

Dim nomeFileSalvato As String

Dim lngLastRow      As Long

Const strClass      As String = "Excel.Application"

lune = Year(txtDataLun) & "." & Month(txtDataLun) & "." & Day(txtDataLun)

saba = Year(txtDataSab) & "." & Month(txtDataSab) & "." & Day(txtDataSab)

' prova a sostituire le istruzioni di cui sopra come segue :

'lune =format$(txtDataLun,"yyyy.m.d")

'saba=format$(txtDataSab,"yyyy.m.d")

nomeFileSalvato = "c:\pianificazione\settimana_" & lune & "_" & saba & ".xlsx"

On Error Resume Next

Set oExcel = GetObject(, strClass)

If Err.Number = 429 Then

    Set oExcel = CreateObject(strClass)

End If

On Error GoTo 0

Set oBook = oExcel.Workbooks.Open(nomeFileSalvato)

'---------------------------------------------------

' AGISCO SUL PRIMO FOGLIO: LUNEDI'

'---------------------------------------------------

   Set oSheet = oBook.Worksheets(1)

   'row = 2

'-----------

    On Error Resume Next

    lngLastRow = LastRow(oSheet)

    With oSheet

        Set Rng = .Range(oSheet.Cells(2, 7), .Cells(lngLastRow, 7))

    End With

    Set Rng = Rng.SpecialCells(2, 2) 'xlConstants, xlTextValues

    If Rng Is Nothing Then Exit Sub

    On Error GoTo 0

    For Each Cell In Rng

        If Cell.Value = "A" Then

            If FoundCells Is Nothing Then

                Set FoundCells = Cell

            Else

                Set FoundCells = oExcel.Union(FoundCells, Cell)

            End If

        End If

     Next

     With FoundCells

       .Font.Bold = True

       .HorizontalAlignment = -4108

     End With

     With FoundCells.Interior

             .Pattern = 1

             .PatternColorIndex = -4105 ' xlAutomatic

             .Color = RGB(255, 255, 0) 'giallo carico

             .TintAndShade = 0

             .PatternTintAndShade = 0

     End With

     With oExcel

         .displayAlerts = False

         oBook.Close SaveChanges:=True _

              , FileName:=nomeFileSalvato

        .displayAlerts = True

     End With

     VBA.MsgBox prompt:="Ho finito.", _

                buttons:=vbInformation + vbOKOnly, _

                title:="Info"

exitErrorHandler:

Set FoundCells = Nothing

Set Cell = Nothing

Set oSheet = Nothing

Set oBook = Nothing

oExcel.Quit

Set oExcel = Nothing

    Exit Sub

errorHandler:

    With Err

            MsgBox "ERR#" & CStr(.Number) _

                & vbNewLine & .Description _

                , vbOKOnly Or vbCritical

     End With

     Resume exitErrorHandler

End Sub

    Public Function LastRow(SH As Object, _

                            Optional Rng As Object)

   ' Norman David Jones's function

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    'LastRow = Rng.Find(What:="*", _

    '                   after:=Rng.Cells(1), _

    '                   Lookat:=xlPart, _

    '                   LookIn:=xlFormulas, _

    '                   SearchOrder:=xlByRows, _

    '                   SearchDirection:=xlPrevious, _

    '                   MatchCase:=False).Row

     LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=2, _

                       LookIn:=-4123, _

                       SearchOrder:=1, _

                       SearchDirection:=2, _

                       MatchCase:=False).row

    On Error GoTo 0

End Function

Facci sapere.

Ciao, Sandro.

ps. vedi anche parte in grassetto.
La risposta è stata utile?

0 commenti Nessun commento