Condividi:        

funzione Cerca.vert

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: funzione Cerca.vert

Postdi criscolo67 » 29/07/11 08:58

ciao Anthony, il file originario, cioè quello utilizzato sino ad oggi infatti come da formule postate già funzionava egregiamente con il prelievo dei dati dai vari fogli c8. l'unica problematica che poteva nascere era nel caso di un nuovo dipendente o di uno sposatmento tra reparti in quanto dovevo intervenire nella formula del c8totale cambiando il reparto di prelievo. cmq con la formula di flash penso di aver risolto. devo solo riuscire a far aprire le cartelle reparti all'apertura di quella totale. grazie a tutti per l'interessamento.
criscolo67
Utente Junior
 
Post: 96
Iscritto il: 13/05/11 13:50

Sponsor
 

Re: funzione Cerca.vert

Postdi Anthony47 » 29/07/11 14:12

Avevo erroneamente capito che c' era un problema di tempo di l' esecuzione della macro...

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: funzione Cerca.vert

Postdi Flash30005 » 29/07/11 15:49

Apri il file Chiusura Totale.xls
In un modulo rendi pubblico questo vettore inserendo il codice all'inizio del modulo

Codice: Seleziona tutto
Public VRep(5) As String

poi
Nel VBA del foglio "C8Totale"
inserisci queste macro
Codice: Seleziona tutto
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 For Cart = 1 To 5
    Rep = VRep(Cart)
    On Error Resume Next
    Set WB2 = Workbooks(Rep)
    WB2.Close savechanges:=False
    On Error GoTo 0
Next Cart
End Sub

Private Sub Workbook_Open()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Perc = Application.ThisWorkbook.Path & "\" & Range("S4").Value & Range("V4").Value & "\"
VRep(1) = "stanziale.xls"
VRep(2) = "volante.xls"
VRep(3) = "cinofili.xls"
VRep(4) = "sq.comando.xls"
VRep(5) = "atpi.xls"
For Cart = 1 To 5
    Workbooks.Open Filename:=Perc & VRep(Cart)
Next Cart
ThisWorkbook.Activate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Calculate
End Sub

Ad ogni apertura file Totale si apriranno tutti e 5 i file
alla chiusura del file Totale gli stessi file si chiuderanno

Essendo ora il File Totale realizzato con formule ti ho modificato la macro precedente
commentando righe che non occorrono
per farti ottenere in un baleno tutti i reparti nella colonna AO
In maniera tale da far funzionare il riferimento reparto
Nel caso che un dipendente viene spostato di reparto
tu non devi far altro che avviare questa macro
Verrà corretto il reparto di quel dipendente nella colonna AO
e la formula che andava in errore ND#, ora, darà il valore voluto

Codice: Seleziona tutto
Public VRep(5) As String
Sub TrovaRep()   '<<<< eliminare se già dichiarato in altri moduli
Start = Timer

Application.ScreenUpdating = False
Application.Calculation = xlManual
Perc = Application.ThisWorkbook.Path & "\" & Range("S4").Value & Range("V4").Value & "\"
VRep(1) = "stanziale.xls"
VRep(2) = "volante.xls"
VRep(3) = "cinofili.xls"
VRep(4) = "sq.comando.xls"
VRep(5) = "atpi.xls"
UR1 = Range("C" & Rows.Count).End(xlUp).Row
Dim WB1 As Workbook
Dim WB2 As Workbook

Dim Ws1, Ws2 As Worksheet
Set WB1 = ThisWorkbook
Set Ws1 = WB1.Worksheets("C8totale")

For RR1 = 12 To UR1
    If RR1 = 47 Then GoTo Fine
    Rep = Ws1.Range("AO" & RR1).Value
    If Rep = "" Then
    Trov = 0
Trovatutti:

        For Cart = 1 To 5
            'Workbooks.Open Filename:=Perc & VRep(Cart)
            Set WB2 = Workbooks(VRep(Cart))
            Set Ws2 = WB2.Worksheets("C8")
            UR2 = Ws2.Range("C" & Rows.Count).End(xlUp).Row
            WB1.Activate
            On Error Resume Next
            RR2 = 1
            RR2 = Application.WorksheetFunction.Match(Ws1.Range("C" & RR1), Ws2.Range("C1:C" & UR2), 0)
            If RR2 = 1 Then GoTo Esci
            'Ws2.Range("F" & RR2 & ":Z" & RR2).Copy Destination:=Ws1.Range("F" & RR1)
            Ws1.Range("AO" & RR1).Value = VRep(Cart)
            Trov = 1
            GoTo Salta
Esci:
            On Error GoTo 0
           ' WB2.Close savechanges:=False
        Next Cart
Salta:
        On Error GoTo error_Msgc
       ' WB2.Close savechanges:=False
    Else
       ' Workbooks.Open Filename:=Perc & Rep
        Set WB2 = Workbooks(Rep)
        Set Ws2 = WB2.Worksheets("C8")
        UR2 = Ws2.Range("C" & Rows.Count).End(xlUp).Row
        WB1.Activate
        On Error Resume Next
        RR2 = 1
        RR2 = Application.WorksheetFunction.Match(Ws1.Range("C" & RR1), Ws2.Range("C1:C" & UR2), 0)
        If RR2 = 1 Then GoTo Trovatutti
        'Ws2.Range("F" & RR2 & ":Z" & RR2).Copy Destination:=Ws1.Range("F" & RR1)
        Trov = 1
        On Error GoTo 0
       ' WB2.Close savechanges:=False
    End If
If Trov = 0 Then GoTo error_Msgc
Next RR1
Fine:
Call Formatta
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Tempo = Int(Timer - Start)
MsgBox Tempo
Exit Sub

error_Msgc:
    'Workbooks(Rep).Close savechanges:=False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Dipendente " & Range("C" & RR1).Value & " non trovato in nessun Reparto", vbInformation
On Error GoTo 0

End Sub


Nota importante avendo tutti i file aperti potresti ripristinare (in questa ultima macro) solo i commenti riguardanti
il copia dati dai fogli
Non ripristinare i 'Workbooks.Open Filename:=Perc & VRep(Cart) e nemmeno i ' WB2.Close savechanges:=False
Penso che avrai una bellissima sorpresa ;)

Applicherai un pulsante che potrai chiamare "Agg Rep" ;)
Prova e fai sapere
ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: funzione Cerca.vert

Postdi criscolo67 » 29/07/11 23:23

grazie flash...
l'apertura dei fogli funziona perfettamente, mentre la seconda prova possiamo dire che in velocità di esecuzione siamo ancora lontani dal mio bisogno...cmq con l'apetura dei fogli e la formula da te suggerita il tutto funziona perfettamente, rispettando i miei bisogni...per quanto riguarda un eventuale cambio di reparto agisco personalmente sulla colonna A8...per me è un grande passo avanti...grazie per la pazienza...
criscolo67
Utente Junior
 
Post: 96
Iscritto il: 13/05/11 13:50

Re: funzione Cerca.vert

Postdi Flash30005 » 29/07/11 23:42

Fammi capire
lasciando la macro con i commenti in maniera tale che aggiorni da sola i reparti rimangono tempi lungi (sempreché i file siano aperti)?

In pratica dimentica tutte le macro postate ma concentrati solo su quella del post "risolutivo" con formule
e macro commentata sfruttando la macro solo per aggiornamento reparto

come ti trovi?
tempi lunghi?
se si, devi considerare una cosa:
non cambi il posto ad un dipendente tutti i giorni quindi non la userai quasi mai e quindi
userai le formule (che si riferiranno alla colonna AO) e i file aperti.
Nel caso in cui un dipendente non è più nel file reparto
avrai in corrispondenza delle formule un errore tipo ND# allora avvierai la macro che aggiorna SOLO la colonna AO (quella con tutti i commenti) anche se impiega tempo lo farai "una tantum" ma avrai la certezza di non intervenire manualmente con possibilità di errore umano.

Penso che sia questa la soluzione più adeguata al tuo problema

Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: funzione Cerca.vert

Postdi Anthony47 » 30/07/11 13:31

Anthony ha scritto:Avevo erroneamente capito che c' era un problema di tempo di l' esecuzione della macro...
Ma forse avevo capito bene...
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Precedente

Torna a Applicazioni Office Windows


Topic correlati a "funzione Cerca.vert":


Chi c’è in linea

Visitano il forum: Nessuno e 51 ospiti