Moderatori: Anthony47, Flash30005
Public VRep(5) As String
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
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
Ma forse avevo capito bene...Anthony ha scritto:Avevo erroneamente capito che c' era un problema di tempo di l' esecuzione della macro...
Torna a Applicazioni Office Windows
cerca il più grande numero di celle vuote in un intervallo Autore: papiriof |
Forum: Applicazioni Office Windows Risposte: 2 |
Funzione CERCA ma con colonne dinamiche Autore: Paolo67met |
Forum: Applicazioni Office Windows Risposte: 2 |
Excel 2016 - Funzione SCARTO + INDIRETTO Autore: pl1957 |
Forum: Applicazioni Office Windows Risposte: 2 |
Nomogramma e funzione matematica in excel... Autore: Paolo67 |
Forum: Applicazioni Office Windows Risposte: 53 |
Visitano il forum: Nessuno e 71 ospiti