Ma riepiloghiamo:
Ho un file su cui "pasticcio" da anni chiamato schema entrate da duplicare.xlsm e grazie ai consigli di Anthony, ma non solo, sono riuscito ad aggiungervi diverse funzionalità ed automatismi che lo rendono decisamente performante.
Lo schema serve per l'inserimento dei dati dei mezzi che entrano ed escono dal magazzino e viene compilato da più operatori, ma a turno, mai in contemporanea.
Il file Ora da diversi mesi, come accennato in principio, non si salva più se modificato in alcune zone come impostato.
La macro che regola il salvataggio nel foglio1 (ENTRATE) è la seguente:
- Codice: Seleziona tutto
Dim myRan As String
'
myRan = "L2:L201" '<<< L'area per i cui cambiamenti viene subito fatto un File Save
If Application.Intersect(Target, Range(myRan)) Is Nothing Then Exit Sub
Debug.Print Now, Target.Address
ThisWorkbook.Save
Al momento la macro è l'ultima prima della fine della
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
e così non funziona.. spostandola più su e quindi come penultima invece si però la macro successiva
- Codice: Seleziona tutto
Dim myList
myList = Array("SERBIA", "BOSNIA", "EUROTHENA")
If Target.Count = 1 Then '1
If Intersect(Target, Range("F2:F201")) Is Nothing Then Exit Sub
For I = 0 To UBound(myList)
If InStr(1, Cells(Target.Row, 6).Value, myList(I), vbTextCompare) > 0 Then
Cells(Target.Row, 14).Value = "PRECEDENZA T1"
Exit For
End If
Next I
End If
smette di funzionare.
Al momento LA WorksheetChange del foglio ENTRATE è così popolata:
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
Dim ordine As String
Dim SClients, YFlag As Boolean, I As Long, CCVal
SClients = Array("EUSIDER", "BIDUE", "METALL STEEL")
If Not Intersect(Target, Me.Range("H2:H201")) Is Nothing Then
For Each cell In Target
'Controlla se cliente speciale:
YFlag = False
CCVal = Cells(cell.Row, 6).Value & "....."
For I = 0 To UBound(SClients)
If InStr(1, CCVal, SClients(I), vbTextCompare) > 0 Then
YFlag = True
Exit For
End If
Next I
If YFlag And Not IsEmpty(cell.Value) Then
ordine = InputBox("Nr.Ordine Eusider")
If ordine <> "" Then
Me.Cells(cell.Row, 15).Value = ordine
If Target.Count = 1 Then
Cells(cell.Row, "P").Select
Exit Sub
End If
End If
End If
Next cell
End If
If Target.Count = 1 Then
If Not Intersect(Target, Range("B2:P201")) Is Nothing Then
Select Case Target.Column
Case Is = 2 'B..
Target.Offset(0, 1).Select '..C
Case Is = 3 'C..
Target.Offset(0, 3).Select '..F
Case Is = 6 'F..
Target.Offset(0, 2).Select '..H
Case Is = 8 'H..
Target.Offset(0, 1).Select '..I
Case Is = 9 'I..
Target.Offset(0, 7).Select '..P
Case Is = 16 'P..
Target.Offset(1, -14).Select '..B+1
End Select
End If
End If
If Target.Count = 1 Then
If Target.Column = 2 Then
Application.EnableEvents = False
Call Pusher(Target.Value, "|", Target.Row)
Application.EnableEvents = True
End If
End If
Dim cvArea As String, cvElenco As Range, myCk
Dim DizArea As Range
'
'Parametri>>>:
cvArea = "H2:H201" 'Area Convalidata
Set cvElenco = Sheets("MERCI").Range("B16:B100") 'Area con le voci di convalida
Set DizArea = Sheets("MERCI").Range("D2:E50") 'Area del Dizionario
'
'Controlla se va fatta la verifica:
If Target.Count = 1 And (Not Application.Intersect(Target, Range(cvArea)) Is Nothing) Then
myCk = Application.WorksheetFunction.CountIf(cvElenco, Target.Value) 'Controlla se l'input e' in elenco
If myCk = 0 And Target.Value <> "" Then 'Non c'è
Application.EnableEvents = False
myCk = Application.VLookup(Target.Value, DizArea, 2, False) 'Cerca.Vert nel dizionario
If IsError(myCk) Then 'Non c'è:
With cvElenco.Cells(1, 1).End(xlDown).Offset(1, 0) 'Va in fondo all'elenco...
.Value = Target.Value '...ci aggiunge quel valore
.Interior.Color = RGB(255, 200, 200) '...e lo coloora in rossastro
End With
Else 'Se trova quella voce...
Target.Value = myCk '...sostituisce l'input
End If
Application.EnableEvents = True
End If
End If
Dim myRan As String
'
myRan = "L2:L201" '<<< L'area per i cui cambiamenti viene subito fatto un File Save
If Application.Intersect(Target, Range(myRan)) Is Nothing Then Exit Sub
Debug.Print Now, Target.Address
ThisWorkbook.Save
Dim myList
myList = Array("SERBIA", "BOSNIA", "EUROTHENA")
If Target.Count = 1 Then '1
If Intersect(Target, Range("F2:F201")) Is Nothing Then Exit Sub
For I = 0 To UBound(myList)
If InStr(1, Cells(Target.Row, 6).Value, myList(I), vbTextCompare) > 0 Then
Cells(Target.Row, 14).Value = "PRECEDENZA T1"
Exit For
End If
Next I
End If
End Sub
E' possibile far convivere tutte le macro? Perchè in questo caso le macro sembrano andare in conflitto?
Aiutatemi a capire per favore.
Ps
Allego file allo stato attuale della "progettazione".
