Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

Routine troppo grande

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Re: Routine troppo grande

Postdi ricky53 » 21/03/12 11:16

Ciao,
visto che ci sono ecco la macro parte finale di "GENERA" alla quale ho tolto tutto il codice che gestisce gli "ECO" (ho riportato solo l'ultimo Sfere PRO 450 per farti vedere dove inserire la chiamata a "GENERA_BIS"
Codice: Seleziona tutto
Public Sub Genera()
CUT

   
' Sfere PRO 450
    With sh1
        lRiga1 = .Range("A" & .Rows.Count).End(xlUp).Row
        lRiga2 = sh6.Range("A" & .Rows.Count).End(xlUp).Row
        If lRiga2 < 5 Then lRiga2 = 4
           
    'filtro per Sfere PRO 450
        Sheets("Forniture").Select
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=5, Criteria1:="=P-450", _
            Operator:=xlAnd
             
        If .Range("A4" & lRiga1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            With sh6
                .Range("A" & lRiga2 + 3).Value = "Codice"
                .Range("B" & lRiga2 + 3).Value = "Nome Progetto"
                .Range("C" & lRiga2 + 3).Value = "Solaio"
                .Range("D" & lRiga2 + 3).Value = "Sistema"
                .Range("E" & lRiga2 + 3).Value = "Tipologia alleggerimento"
                .Range("F" & lRiga2 + 3).Value = "Nr. Sfere"
                .Range("G" & lRiga2 + 3).Value = "Nr. Gabbie"
                .Range("H" & lRiga2 + 3).Value = "Disegno Modulo"
                .Range("I" & lRiga2 + 3).Value = "Connettori"
                .Range("J" & lRiga2 + 3).Value = "Impresa"
                .Range("K" & lRiga2 + 3).Value = "Produz."
                .Range("L" & lRiga2 + 3).Value = "Relaz. Tecnica"
                .Range("M" & lRiga2 + 3).Value = "Superficie getto [mq]"
                .Range("N" & lRiga2 + 3).Value = "Prefabbric."
                With .Range("A" & lRiga2 + 3 & ":N" & lRiga2 + 3)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlTop
                    .WrapText = True
                End With
            End With
'copio/incollo
            .Range("A4:N100" & lRiga1).Copy _
                Destination:=sh6.Range("A" & lRiga2 + 4)
            With sh6
                lRigafine = .Range("A" & .Rows.Count).End(xlUp).Row
                .Range("F" & lRigafine + 1).Value = "=SUM(" & sh6.Name & "!F" & lRiga2 + 4 & ":F" & lRigafine & ")"
                With .Range("F" & lRigafine + 1)
                    .Font.Bold = True
                    .NumberFormat = "0"" sf"""
                    .Font.Color = -16776961
                End With
                lRigafine = .Range("A" & .Rows.Count).End(xlUp).Row
                .Range("G" & lRigafine + 1).Value = "=SUM(" & sh6.Name & "!G" & lRiga2 + 4 & ":G" & lRigafine & ")"
                With .Range("G" & lRigafine + 1)
                    .Font.Bold = True
                    .NumberFormat = "0.00"" g"""
                    .Font.Color = -16776961
                End With
                lRigafine = .Range("A" & .Rows.Count).End(xlUp).Row
                .Range("M" & lRigafine + 1).Value = "=SUM(" & sh6.Name & "!M" & lRiga2 + 4 & ":M" & lRigafine & ")"
                With .Range("M" & lRigafine + 1)
                    .Font.Bold = True
                    .NumberFormat = "0.00"" mq"""
                    .Font.Color = -16776961
                End With
            End With
            With sh6
                Call mBordi1(.Range("A" & lRiga2 + 3 & ":N" & lRigafine))
                Call mBordi2(.Range("A" & lRiga2 + 4 & ":N" & lRigafine))
            End With
        End If
    End With
'tolgo il filtro nel foglio FILE_txt
    With sh1
        .Range("$A$3:$N$3").AutoFilter Field:=5
    End With
   
   
'++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++
    Call Genera_BIS(sh1, sh6)
'++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++


'ripristino l'aggiornamento del monitor
    Application.ScreenUpdating = True
'Set a Nothing delle variabili oggetto
    Set sh = Nothing
    Set sh1 = Nothing
    Set sh2 = Nothing
    Set sh3 = Nothing
    Set sh4 = Nothing
    Set sh5 = Nothing
    Set sh6 = Nothing
End Sub
Dice il vecchio saggio provare e riprovare è l'unica strada per imparare

Più chiara è la vostra spiegazione
Più immediata sarà la nostra soluzione


. . . . . . . . . .
S.O. W7; Office 2003-10-13-16
Avatar utente
ricky53
Utente Senior
 
Post: 4223
Iscritto il: 11/04/09 19:29
Località: Italia

Sponsor
 

Re: Routine troppo grande

Postdi ricky53 » 21/03/12 14:22

Ciao,
nei due miei precedenti interventi ti ho inserito due macro che ho prodotto spezzando la tua macroche aveva il problema della grandezza.


ADESSO a noi: come promesso ecco la macro che elimina la ripetizione (22 volte) delle stesse istruzioni.

Non ho analizzato il codice, ho solo eliminato le ripetizioni inserendo un ciclo For/Next (ho dovuto fare una correzione che ti ho evidenziato) ma rimane, a mio avviso l'esigenza di rivere il codice per alleggerirlo da diverse cose. Se i dati non sono tanti lo lascerei così ... vedi tu.
Codice: Seleziona tutto
Option Base 1
Option Explicit

Public Sub Genera_NEW()
'dichiaro le variabili
    Dim lRisposta As Long
    Dim sh As Worksheet
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Dim sh4 As Worksheet
    Dim sh5 As Worksheet
    Dim sh6 As Worksheet
    Dim lRiga1 As Long
    Dim lRiga2 As Long
    Dim lRigafine As Long
'metto un riferimento ai fogli
    With ThisWorkbook
        Set sh1 = .Worksheets("Forniture")
        Set sh2 = .Worksheets("Caltiber")
        Set sh3 = .Worksheets("Nicofer")
        Set sh4 = .Worksheets("Garbin")
        Set sh5 = .Worksheets("Siderurgica")
        Set sh6 = .Worksheets("TipoSfere")
    End With
'skrolling del monitor
    Application.ScreenUpdating = False
    For Each sh In Worksheets(Array("Caltiber", "Nicofer", "Siderurgica", "Garbin"))
        sh.Range("A4:N100").Delete Shift:=xlUp
    Next
    For Each sh In Worksheets(Array("TipoSfere"))
        sh.Range("A1:N100").Delete Shift:=xlUp
    Next
    With sh1
        Range("A3:N3").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=14, Criteria1:= _
            "=Caltiber", Operator:=xlAnd
        Rows("4:100").Select
        Selection.Copy
        Sheets("Caltiber").Select
        Range("A4").Select
        ActiveSheet.Paste
        Range("A1:N2").Select
        Sheets("Forniture").Select
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=14
        Range("A1:N2").Select
        Application.CutCopyMode = False
    End With
    With sh1
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=14, Criteria1:="=NicoFer" _
            , Operator:=xlAnd
        Rows("4:100").Select
        Selection.Copy
        Sheets("Nicofer").Select
        Range("A4").Select
        ActiveSheet.Paste
        Range("A1:N2").Select
        Sheets("Forniture").Select
        Range("A1:N2").Select
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=14
        Application.CutCopyMode = False
    End With
    With sh1
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=14, Criteria1:="=Garbin" _
            , Operator:=xlAnd
        Rows("4:100").Select
        Selection.Copy
        Sheets("Garbin").Select
        Range("A4").Select
        ActiveSheet.Paste
        Range("A1:N2").Select
        Sheets("Forniture").Select
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=14
        Range("A1:N2").Select
        Application.CutCopyMode = False
    End With
    With sh1
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=14, Criteria1:="=Siderurgica" _
            , Operator:=xlAnd
        Rows("4:100").Select
        Selection.Copy
        Sheets("Siderurgica").Select
        Range("A4").Select
        ActiveSheet.Paste
        Range("A1:N2").Select
        Sheets("Forniture").Select
        ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=14
        Range("A1:N2").Select
        Application.CutCopyMode = False
    End With
'impagino il Foglio Distinte Sfere
    With sh6
        With .Range("A:N")
        .Delete Shift:=xlUp
        End With
        With .Range("A:A")
        .Columns.ColumnWidth = 9
        End With
        With .Range("B:B")
        .Columns.ColumnWidth = 25
        End With
        With .Range("C:C")
        .Columns.ColumnWidth = 12
        End With
        With .Range("D:D")
        .Columns.ColumnWidth = 8
        End With
        With .Range("E:E")
        .Columns.ColumnWidth = 12
        End With
        With .Range("F:L")
        .Columns.ColumnWidth = 10
        End With
        With .Range("M:N")
        .Columns.ColumnWidth = 12
        End With
    End With
   
'..........................................................................................
' INIZIO istruzioni del ciclo sui 22 elementi delle SFERE
    Dim Ind As Integer
    Dim Matr_Sfere(22)
    Matr_Sfere(1) = "S-100/225"
    Matr_Sfere(2) = "S-100/315"
    Matr_Sfere(3) = "S-120/315"
    Matr_Sfere(4) = "S-140/315"
    Matr_Sfere(5) = "S-160/315"
    Matr_Sfere(6) = "S-180/315"
    Matr_Sfere(7) = "S-200/315"
    Matr_Sfere(8) = "S-220/315"
    Matr_Sfere(9) = "P-180"
    Matr_Sfere(10) = "P-180-A"
    Matr_Sfere(11) = "P-225"
    Matr_Sfere(12) = "P-225-A"
    Matr_Sfere(13) = "P-270"
    Matr_Sfere(14) = "P-270-A"
    Matr_Sfere(15) = "P-360"
    Matr_Sfere(16) = "P-360-A"
    Matr_Sfere(17) = "P-405"
    Matr_Sfere(18) = "P-450"
    Matr_Sfere(19) = "E-180"
    Matr_Sfere(20) = "E-225"
    Matr_Sfere(21) = "E-270"
    Matr_Sfere(22) = "E-360"
   
    For Ind = 1 To UBound(Matr_Sfere)
        With sh1
            lRiga1 = .Range("A" & .Rows.Count).End(xlUp).Row
            lRiga2 = sh6.Range("A" & .Rows.Count).End(xlUp).Row + 4 ' <<========= Modificata
            If lRiga2 < 5 Then lRiga2 = 4
           
            If Matr_Sfere(Ind) = "S-100/225" Then
                With sh6
                    .Range("A" & lRiga2 - 3 & ":N" & lRiga2 - 3).MergeCells = True
                    With .Range("A" & lRiga2 - 3 & ":N" & lRiga2 - 3)
                        .Value = "FORNITURE COBIAX ANNO 2011 - ORDINATE PER TIPOLOGIA SFERE"
                        .VerticalAlignment = xlCenter
                        .WrapText = True
                        .Font.Bold = True
                        .Font.Size = 14
                        .HorizontalAlignment = xlCenter
                        .Rows.RowHeight = 20#
                    End With
                End With
            End If
           
            Sheets("Forniture").Select
            ActiveSheet.Range("$A$3:$N$100").AutoFilter Field:=5, Criteria1:= _
                Matr_Sfere(Ind), Operator:=xlAnd
       
            If Range("A" & Rows.Count).End(xlUp).Row > 3 Then ' <========== Sostitusce l'istruzione seguente
' TOLTA perchè scriveva intestazioni senza dati e creava dei riferimenti circolari
'            If .Range("A4" & lRiga1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                sh6.Range("A" & lRiga2).CurrentRegion.ClearFormats
                With sh6
                    .Range("A" & lRiga2 - 1).Value = "Codice"
                    .Range("B" & lRiga2 - 1).Value = "Nome Progetto"
                    .Range("C" & lRiga2 - 1).Value = "Solaio"
                    .Range("D" & lRiga2 - 1).Value = "Sistema"
                    .Range("E" & lRiga2 - 1).Value = "Tipologia alleggerimento"
                    .Range("F" & lRiga2 - 1).Value = "Nr. Sfere"
                    .Range("G" & lRiga2 - 1).Value = "Nr. Gabbie"
                    .Range("H" & lRiga2 - 1).Value = "Disegno Modulo"
                    .Range("I" & lRiga2 - 1).Value = "Connettori"
                    .Range("J" & lRiga2 - 1).Value = "Impresa"
                    .Range("K" & lRiga2 - 1).Value = "Produz."
                    .Range("L" & lRiga2 - 1).Value = "Relaz. Tecnica"
                    .Range("M" & lRiga2 - 1).Value = "Superficie getto [mq]"
                    .Range("N" & lRiga2 - 1).Value = "Prefabbric."
                    With .Range("A" & lRiga2 - 1 & ":N" & lRiga2 - 1)
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlTop
                        .WrapText = True
                    End With
                End With
                .Range("A4:N100" & lRiga1).Copy _
                    Destination:=sh6.Range("A" & lRiga2)
                With sh6
                    lRigafine = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("F" & lRigafine + 1).Value = "=SUM(" & sh6.Name & "!F" & lRiga2 & ":F" & lRigafine & ")"
                    With .Range("F" & lRigafine + 1)
                        .Font.Bold = True
                        .NumberFormat = "0"" sf"""
                        .Font.Color = -16776961
                    End With
                    .Range("G" & lRigafine + 1).Value = "=SUM(" & sh6.Name & "!G" & lRiga2 & ":G" & lRigafine & ")"
                    With .Range("G" & lRigafine + 1)
                        .Font.Bold = True
                        .NumberFormat = "0.00"" g"""
                        .Font.Color = -16776961
                    End With
                    .Range("M" & lRigafine + 1).Value = "=SUM(" & sh6.Name & "!M" & lRiga2 & ":M" & lRigafine & ")"
                    With .Range("M" & lRigafine + 1)
                        .Font.Bold = True
                        .NumberFormat = "0.00"" mq"""
                        .Font.Color = -16776961
                    End With
                End With
                With sh6
                    Call mBordi1(.Range("A" & lRiga2 - 1 & ":N" & lRigafine))
                    Call mBordi2(.Range("A" & lRiga2 & ":N" & lRigafine))
                End With
            End If
        End With
        With sh1
            .Range("$A$3:$N$3").AutoFilter Field:=5
        End With
    Next Ind
' FINE istruzioni del ciclo sui 22 elementi delle SFERE
'..........................................................................................
   
    Application.ScreenUpdating = True

    MsgBox "Fine Elaborazione"
    Set sh = Nothing
    Set sh1 = Nothing
    Set sh2 = Nothing
    Set sh3 = Nothing
    Set sh4 = Nothing
    Set sh5 = Nothing
    Set sh6 = Nothing
End Sub


Mi sembra che il codice faccia quello che faceva prima, tranne la scrittura di sezioni di SFERE vuote che ho "volutamente" eliminato (leggi il commento nel codice) perchè non ritenevo utile avere delle sezioni vuote e inoltre creavano dei riferimenti circolari.

Prova e ... sono QUI !!!
Dice il vecchio saggio provare e riprovare è l'unica strada per imparare

Più chiara è la vostra spiegazione
Più immediata sarà la nostra soluzione


. . . . . . . . . .
S.O. W7; Office 2003-10-13-16
Avatar utente
ricky53
Utente Senior
 
Post: 4223
Iscritto il: 11/04/09 19:29
Località: Italia

Re: Routine troppo grande

Postdi Alea » 21/03/12 16:13

Ma... praticamente hai riscritto il codice snellendolo un casino?....
Non so proprio come ringraziarti. Oggi purtroppo però non riesco a provare. Ti faccio sapere domani.
Intanto di ringrazio tantissimo.
Alea
Utente Senior
 
Post: 145
Iscritto il: 24/07/06 14:12

Re: Routine troppo grande

Postdi maxmula » 23/03/12 22:17

Eh sì, mi sa che chi ha scritto il codice originale della macro sia andato giù in modo abbastanza pesante col CopiaIncolla...

Nulla da aggiungere circa la semplificazione, per quanto riguarda l'indentazione, invece, mi permetto di suggerire l'utility Smart Indenter (http://www.oaltd.co.uk/indenter/default.htm), che permette di sistemare "come si deve" anche le routine più incasinate :)

Usarlo è semplicissimo: si scarica il pacchetto (quello per Office 2003, in questo caso), s'installa e si riavvia Excel: a quel punto nel menu Modifica (Edit) dell'editor vba è disponibile la voce "Smart Indent".
La compatibilità dichiarata è fino a office 2003 ma non ci sono problemi nemmeno con 2007 (sperimentato personalmente).
Da provare!

Ciao,
Max
Avatar utente
maxmula
Utente Senior
 
Post: 965
Iscritto il: 18/08/04 18:28
Località: N44°59'45 E09°00'34

Re: Routine troppo grande

Postdi Alea » 26/03/12 13:20

Chiedo scusa a tutti quelli che mi stanno aiutando ma in questi giorni sono abbastanza incasinato. spero di trovare tempo in settimana per provare tutto.
Grazie
Alea
Utente Senior
 
Post: 145
Iscritto il: 24/07/06 14:12

Re: Routine troppo grande

Postdi Alea » 05/04/12 14:04

Finalmente sono riuscito a trovare il tempo per leggere attentamente questo post.
E devo fare un enorme ringraziamento a Ricky che praticamente ha risolto tutti i miei problemi in maniera fantastica.
Grazie mille
Ciao
Alea
Utente Senior
 
Post: 145
Iscritto il: 24/07/06 14:12

Re: Routine troppo grande

Postdi ricky53 » 05/04/12 15:29

Ciao,
mi fa piacere esserti stato utile.

Alla prossima.
Dice il vecchio saggio provare e riprovare è l'unica strada per imparare

Più chiara è la vostra spiegazione
Più immediata sarà la nostra soluzione


. . . . . . . . . .
S.O. W7; Office 2003-10-13-16
Avatar utente
ricky53
Utente Senior
 
Post: 4223
Iscritto il: 11/04/09 19:29
Località: Italia

Precedente

Torna a Applicazioni Office Windows


Topic correlati a "Routine troppo grande":


Chi c’è in linea

Visitano il forum: Nessuno e 11 ospiti