Condividi:        

cerca nomi

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: cerca nomi

Postdi Anthony47 » 16/06/12 01:11

Per gestire il checkbox aggiungi la riga marcata *1 e modifica quella marcata *2
Codice: Seleziona tutto
With ActiveSheet.Range("AB3:AB100, A3:B2000")
If CheckBox2.Value = True Then lAt = 1 Else lAt = 2      '*1
    If myPrimo Is Nothing Then
        myK1 = 0
        Set c = .Find(TextBox1.Text, LookIn:=xlValues, lookat:=lAt)       '*2
    Else: Set c = .FindNext(myCorr)
    End If

La modifica al checkbox la potrai fare col mouse; farlo con Contr-i implica che la form venga deselezionata, non mi pare un' operazione piu' intuitiva e veloce del cliccare sull' oggetto, e in un precedente messaggio gia' il deselezionare del textbox mi sembrava sgradito.

La modifica impostata col checkbox sara' applicata solo alla ripartenza della ricerca (cioe' quando viene cercato il primo valore); se vuoi forzare il riavvio aggiungi questo codice di gestione
Codice: Seleziona tutto
Private Sub CheckBox2_Click()
Set myPrimo = Nothing
TextBox1.SetFocus
End Sub

Inoltre la variazione ha effetto solo nella ricerca in cella, non nei commenti. Se vuoi riportare la stessa logica ai commenti, allora sostituisci questa linea
If Len(UCase(Kmt.Text)) > Len(Replace(UCase(Kmt.Text), UCase(TextBox1.Text), "")) Then
Con queste:
Codice: Seleziona tutto
MyFlag=0
If CheckBox2.value=True and UCase(Kmt.Text)= UCase(TextBox1.Text) then MyFlag=True
If CheckBox2.value=False and Len(UCase(Kmt.Text)) > Len(Replace(UCase(Kmt.Text), UCase(TextBox1.Text), "")) Then myFlag=True
If myFlag=True then

NB: ho usato CheckBox2 perche' nel file che avevi pubblicato questo era il nome del C.Box presente sulla form.

Che sia l' ultima?
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Sponsor
 

Re: cerca nomi

Postdi trittico69 » 16/06/12 10:59

scusami forse mi sono espreso male... in pratica come hai fatto tu mi cerca un unica parola nella cella...a me servirebbe che se in una cella c'è "uno due tre quattro" e in un altra c'è "unoduetrequattro" e la parola da cercare è "due" mi deve evidenziare la prima cella, anche se in questa ci sono più parole e ovviamente anche se c'è solo la parola da cercare come fa adesso con l'ultima modifica che mi hai fatto fare..e se è possibile di considerare le parole accentate..ad esempio se devo cercare la parola però o pero' o pero se io scrivo nella finestra pero me le deve cercare tutte.
grazie per la pazienza.
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi Anthony47 » 16/06/12 16:01

Vedro' cosa posso fare...
Pero' alla domanda
Ora se scrivi "monte" ti trovera' i vari monte, montella, delmonte, monte leggero, mazzanti vien dal monte, cordero di montezemolo, smontero, e cosi' via; tu invece che cosa vorresti?
avresti dovuto rispondere
"vorrei che trovasse monte, monte leggero e mazzanti vien dal monte"
(e non "mi deve cercare solo monte").

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

Re: cerca nomi

Postdi trittico69 » 19/06/12 21:16

non hai avuto tempo per fare il codice?
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi Anthony47 » 20/06/12 01:34

Vedi, quando si parte con una richiesta e poi si arriva a un' altra spesso tutto quel che si e' fatto e' da buttare; questo e' uno dei casi... Siamo partiti dal cercare una stringa in un testo e siamo arrivati (immagino che non sia ancora la fine) a cercare una parola in una frase.
Questo presuppone buttare il codice sin qui usato (costruito a strati, come a fette arrivavano le tue richieste) e inventarne uno ex novo; non e' la complessita' tecnica, ma e' l' idea di aver perduto tempo che non mi affascina.
Cio' detto, per la ricerca a parole prova questa versione della Sub CommandButton1_Click, come penultimo contributo alla tua causa:
Codice: Seleziona tutto
Private Sub CommandButton1_Click()
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=95607  *******************
'opzione ricerca per parola
'
Dim I As Long
'
If myPrimo Is Nothing Then myCellFound = 0: Set myCorr = Nothing
'
RAvvia:
userform1.Caption = "CERCA in cella"
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
'
myArea = "AB3:AB100, A3:B2000"
If Not myCorr Is Nothing Then GoTo CkCmt
myFlag = 0
For Each myCell In ActiveSheet.Range(myArea)
    If CheckBox2.Value And ComPar(myCell.Value, TextBox1.Text) Then myFlag = True
    If CheckBox2.Value = False And Len(UCase(myCell.Value)) > Len(Replace(UCase(myCell.Value), Trim(UCase(TextBox1.Text)), "")) Then myFlag = True
aaa = myCell.Value
    If myFlag = True Then
        CellFound = CellFound + 1
        myFlag = 0
        If CellFound > myCellFound Then
            Set myPrimo = myCell: myK1 = 0
            myCellFound = myCellFound + 1
            userform1.Caption = "TROVATO in cella"
            myCell.Select: Exit Sub
        End If
    End If
Next myCell
'
'GoTo CkCmt
'
CkCmt:
Set myCorr = ActiveCell
userform1.Caption = "CERCA in commento"
If myPrimo Is Nothing Then Set myPrimo = ActiveCell
If myCorr Is Nothing Then Set myCorr = Range("A1")
'myK1 = 0
For I = myK1 + 1 To ActiveSheet.Comments.Count
    Set Kmt = ActiveSheet.Comments(I)
    If Not Application.Intersect(Kmt.Parent, Range(myArea)) Is Nothing Then
        myFlag = 0
        If CheckBox2.Value = True And ComPar(Kmt.Text, TextBox1.Text) Then myFlag = True
        If CheckBox2.Value = False And Len(UCase(Kmt.Text)) > Len(Replace(UCase(Kmt.Text), Trim(UCase(TextBox1.Text)), "")) Then myFlag = True
        If myFlag = True Then
            myK1 = I: Kmt.Parent.Select
            userform1.Caption = "TROVATO in commento": Exit Sub
        End If
    End If
Next
'
FineKmt:
userform1.Caption = "------> FINE RICERCA"
Set myPrimo = Nothing ': GoTo RAvvia
End Sub

In testa al modulo che contiene questa Sub CommandButton1_Click inserirai
Codice: Seleziona tutto
Dim myPrimo As Range, myCorr As Range, myK1 As Long, myCellFound As Long
(aggiunta la variabile myCellFound)

All' interno di un "Modulo Standard" (io ho usato Modulo2) inserisci
IN TESTA, prima di qualsiasi macro
Codice: Seleziona tutto
Dim mySplip
E poi:
Codice: Seleziona tutto
Function splip(ByVal mySorg As String)
mySplip = Split(UCase(mySorg), " ")
splip = UBound(mySplip)
End Function

Function ComPar(ByVal myCell As String, ByVal myText As String) As Boolean
NumPar = splip(myCell)
For I = 0 To NumPar
    If mySplip(I) = Trim(UCase(myText)) Then ComPar = True: Exit Function
Next I
End Function

Per qanto riguarda il discorso delle lettere accentate preferisco non cimentarmi, anche perche' si comincia con un paio di accenti (grave e acuto), si continua col circonflesso, poi con l' umlaut e si finirebbe ai caratteri speciali...

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

Re: cerca nomi

Postdi trittico69 » 20/06/12 19:22

hai ragione.... è solo che mentre provo sul file originale e lo testo sul lavoro mi vengono in mente altre cose... cioè solo mentre lavori ti accorgi di quello che ti puo servire incappando in varie problematiche.
per quando riguarda gli accenti capiterà solo quello che è necessario per scrivere nomi, senza strani simboli e cioè('ìèéùàò) senza le parentesi...il tuo codice sembra funzionare ma.... lo so che ti avevo chiesto che era l’ultimo codice, tempo fa, ma facciamo così te ne chiedo un altro e se poi te ne chiederò ancora non me lo farai…allora mi servirebbe che se spunto una casella di controllo sempre nella stessa form mi si dovrebbe aprire una finestra e mi fa visualizzare tutte le soluzioni che si stanno cercando, con a fianco i dati che si trovano nelle due celle immediatamente dopo e cioè in totale A-B-C-D.
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi Anthony47 » 21/06/12 11:06

Il ragionamento che hai descritto e' un vizio troppo comune: si pensa poco, si fatica tanto, si conclude poco.

Volendo rispettare il tuo desiderio per un' ultima versione del progetto vorrei capire meglio quali dati vorresti presentare nel caso di spunta di quest' ultima casella; A-B-C-D non mi quadra, sia perche' parlando di "due celle immediatamente dopo" mi sarei immaginato di trovare 3 celle in tutto e non 4, sia perche' la ricerca noi l' abbiamo fatta in due intervalli (AB3:AB100, A3:B2000), quindi immagino siano da prendere in considerazione anche le colonne AC-AD.

Per quanto riguarda il discorso degli accenti anche qui temo che l' analisi sia carente: vuoi dire che non avrai nomi con l' umlaut (es Löwe) o con la tilde (es Niño) o con la cediglia (es Maçon) o con il circonflesso (Bârre) o tutte le complicazioni nella traslitterazione di nomi arabi in caratteri latini, o quelle degli alfabeti nordici o slavi o...

Cio' detto, ho sviluppato la funzione di conversione "ChrConv"; per prova l' ho specializzata a convertire solo alcune combinazioni; ho modificato la macro pubblicata ieri sera per inserire l' utilizzo di questa funzione.
Per specializzare la conversione dovrai elencare i caratteri/le combinazioni da convertire e l' equivalente; ad esempio io ho usato
Codice: Seleziona tutto
è e' é E' È Mc    'Caratteri da convertire
e e  e E  E Mac   'Caratteri sostitutivi

Fai in modo di allineare i caratteri da convertire con i caratteri sostitutivi, usando lo "spazio" per compensare (questa e' solo una convenienza per visualizzare allineate le sequenze, mentre quello che il codice considera e' la posizione ordinale del carattere/combinazione nella stringa).
Se scrivi le stringhe direttamente nell' editor delle macro non avrai difficolta' a garantire l' allineamento, altrimenti usa un font a larghezza fissa (tipo Courier); deve essere chiaro che la ChrConv sostituira' la prima sequenza della prima riga con la prima della seconda riga, la seconda con la seconda, e cosi' via.
La lunghezza delle sequenze possono essere diverse (infatti nell' esempio ho sostituito i due caratteri E' col carattere E, e lo scozzese Mc con l' inglese Mac). Infine la conversione e' "case sensitive", cioe' (vedi l' esempio di prima) McFarland diventera' MacFarland, ma MCFarland rimane inalterato; a scanso di equivoci devi quindi indicare tutte le combinazioni che prevedi di avere.
Le sequenze che si vogliono eliminare vanno inserite in coda nella prima stringa (se nella prima riga ci sono 20 combinazioni e nella seconda solo 17, le combinazioni 18/19/20 saranno cancellate e non sostituite).

Il nuovo codice per CommandButton1_Click ora e':
Codice: Seleziona tutto
Private Sub CommandButton1_Click()
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=95607
'opzione ricerca per parola PIU' CONVERSIONE LETTERE
 '
Dim I As Long
'
If myPrimo Is Nothing Then myCellFound = 0: Set myCorr = Nothing
'
RAvvia:
userform1.Caption = "CERCA in cella"
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
'
myArea = "AB3:AB100, A3:B2000"
If Not myCorr Is Nothing Then GoTo CkCmt
myFlag = 0
For Each myCell In ActiveSheet.Range(myArea)
If myCell.Value <> "" Then
    If CheckBox2.Value And ComPar(ChrConv(myCell.Value), (TextBox1.Text)) Then myFlag = True
    If CheckBox2.Value = False And Len(UCase(ChrConv(myCell.Value))) > Len(Replace(UCase(ChrConv(myCell.Value)), Trim(UCase(ChrConv(TextBox1.Text))), "")) Then myFlag = True
aaa = myCell.Value
    If myFlag = True Then
        CellFound = CellFound + 1
        myFlag = 0
        If CellFound > myCellFound Then
            Set myPrimo = myCell: myK1 = 0
            myCellFound = myCellFound + 1
            userform1.Caption = "TROVATO in cella"
            myCell.Select: Exit Sub
        End If
    End If
End If
Next myCell

GoTo CkCmt

'
CkCmt:
Set myCorr = ActiveCell
userform1.Caption = "CERCA in commento"
If myPrimo Is Nothing Then Set myPrimo = ActiveCell
If myCorr Is Nothing Then Set myCorr = Range("A1")
'myK1 = 0
For I = myK1 + 1 To ActiveSheet.Comments.Count
    Set Kmt = ActiveSheet.Comments(I)
    If Not Application.Intersect(Kmt.Parent, Range(myArea)) Is Nothing Then
        myFlag = 0
        If CheckBox2.Value = True And ComPar(ChrConv(Kmt.Text), ChrConv(TextBox1.Text)) Then myFlag = True
        If CheckBox2.Value = False And Len(UCase(ChrConv(Kmt.Text))) > Len(Replace(UCase(ChrConv(Kmt.Text)), Trim(UCase(ChrConv(TextBox1.Text))), "")) Then myFlag = True
        If myFlag = True Then
            myK1 = I: Kmt.Parent.Select
            userform1.Caption = "TROVATO in commento": Exit Sub
        End If
    End If
Next
'
FineKmt:
userform1.Caption = "------> FINE RICERCA"
Set myPrimo = Nothing ': GoTo RAvvia
End Sub

Mentre nel modulo dove hai gia' inserito Function splip e Function ComPar inserirai:
Codice: Seleziona tutto
Function ChrConv(ByVal myStringa As String) As String
Dim myOld As String, myNew As String, myConvers As String, I As Long
'
myOld = "è e' é E' È Mc"     '<< Le combinazioni da alterare
myNew = "e e  e E  E Mac"    '<< Le combinazioni sostitutive
myConvers = myStringa
'
mySplitO = Split(Application.WorksheetFunction.Trim(myOld), " ")
mySplitN = Split(Application.WorksheetFunction.Trim(myNew), " ")
For I = LBound(mySplitO, 1) To UBound(mySplitO, 1)
    If I <= UBound(mySplitN, 1) Then NewCh = mySplitN(I) Else NewCh = ""
    myConvers = Replace(myConvers, mySplitO(I), NewCh)
Next I
ChrConv = myConvers
End Function

Le righe marcate << sono quelle da personalizzare seguendo le informazioi del testo.

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

Re: cerca nomi

Postdi trittico69 » 22/06/12 14:53

Se faccio la ricerca nel foglio ‘archivio’ mi deve comparire
A:D
AB:AD
se la faccio nel foglio ‘usciti’ basta solo
A
E
H:J
Per quando riguarda i nomi sono quelli scritti prima e cioè '-ì-è-é-ù-à-ò e gli stessi anche in maiuscolo…. per quando riguarda l’apostrofo può capitare a qualsiasi lettera essendo nomi stranieri ma gli esempi citati da te non ci sono e non ci saranno.
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi Anthony47 » 22/06/12 22:48

La funzione ChrConv gia' e' pronta per convertire i caratteri di tuo interesse negli equivalenti caratteri non accentati; devi solo compilare le righe myOld e myNew come ho descritto ieri sera.
Per l' altra prestazione ci sto' lavorando (meglio: sto' pensando di lavorarci :D ).

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

Re: cerca nomi

Postdi trittico69 » 23/06/12 06:10

ok grazie
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi trittico69 » 28/06/12 16:36

ciao anthoni...non hai avuto il tempo di farmi il codice?
parlo di quello di farmi comparire tutti i nomi che hanno la parola cercatan più le celle dette al post precedente.
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi trittico69 » 02/07/12 21:26

mi hai abbandonato
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi Anthony47 » 03/07/12 01:34

Capisco che la delusione sarebbe stata troppo forte...

Prepara una "userform2" abbastanza larga su cui inserisci un listbox (ListBox1) anche lui abbastanza largo da contenere 5 colonne.
Associa a questa nuova form questo codice:
Codice: Seleziona tutto
Private Sub UserForm_Activate()
Me.ListBox1.ColumnCount = 5
Me.ListBox1.ColumnHeads = True
Me.ListBox1.List() = Application.WorksheetFunction.Transpose(myListREs())
End Sub

Sulla form esistente (UserForm1) aggiungi un checkbox; probabilmente si chiamera' CheckBox3 (perche', sul file che avevi pubblicato, il checkbox esistente si chiamava CheckBox2).
Modifica il codice associato alla Userform1 come segue:
Codice: Seleziona tutto
Private Sub CheckBox2_Click()
'>>
Set myPrimo = Nothing: myListI = 0
TextBox1.SetFocus
End Sub

Private Sub CommandButton2_Click()
Sheets("Archivio").Select
TextBox1.SetFocus
'>>
Set myPrimo = Nothing: myListI = 0
End Sub

Private Sub CommandButton3_Click()
Sheets("usciti").Select
TextBox1.SetFocus
'>>
Set myPrimo = Nothing: myListI = 0
End Sub

Private Sub UserForm_initialize()
'>>
ReDim myListREs(1 To 5, 1 To 1)
CommandButton1.Caption = "trova": CommandButton1.Accelerator = "T": CommandButton1.Default = True
userform1.Caption = "cerca"
End Sub

Private Sub CheckBox3_Change()
'>>
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
End Sub

Private Sub CommandButton1_Click()
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=95607
'opzione ricerca per parola PIU' CONVERSIONE LETTERE
'CheckBox3 per eventuale riepilogo su Form2; vedi modifiche marcate >>
 '
Dim I As Long
'>>
NextUB = UBound(myListREs, 2) + 1
ReDim Preserve myListREs(1 To 5, 1 To NextUB)

'
If myPrimo Is Nothing Then myCellFound = 0: Set myCorr = Nothing
'
RAvvia:
userform1.Caption = "CERCA in cella"
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
'
myArea = "AB3:AB100, A3:B2000"
If Not myCorr Is Nothing Then GoTo CkCmt
myFlag = 0
For Each myCell In ActiveSheet.Range(myArea)
If myCell.Value <> "" Then
    If CheckBox2.Value And ComPar(ChrConv(myCell.Value), (TextBox1.Text)) Then myFlag = True
    If CheckBox2.Value = False And Len(UCase(ChrConv(myCell.Value))) > Len(Replace(UCase(ChrConv(myCell.Value)), Trim(UCase(ChrConv(TextBox1.Text))), "")) Then myFlag = True
aaa = myCell.Value
    If myFlag = True Then
        CellFound = CellFound + 1
        myFlag = 0
        If CellFound > myCellFound Then
            Set myPrimo = myCell: myK1 = 0
            myCellFound = myCellFound + 1
            userform1.Caption = "TROVATO in cella"
            myCell.Select
'>>
            If Me.CheckBox3 = True Then CompilaLR1 (Selection.Row)
            Exit Sub
        End If
    End If
End If
Next myCell

GoTo CkCmt

'
CkCmt:
Set myCorr = ActiveCell
userform1.Caption = "CERCA in commento"
If myPrimo Is Nothing Then Set myPrimo = ActiveCell
If myCorr Is Nothing Then Set myCorr = Range("A1")
'myK1 = 0
For I = myK1 + 1 To ActiveSheet.Comments.Count
    Set Kmt = ActiveSheet.Comments(I)
    If Not Application.Intersect(Kmt.Parent, Range(myArea)) Is Nothing Then
        myFlag = 0
        If CheckBox2.Value = True And ComPar(ChrConv(Kmt.Text), ChrConv(TextBox1.Text)) Then myFlag = True
        If CheckBox2.Value = False And Len(UCase(ChrConv(Kmt.Text))) > Len(Replace(UCase(ChrConv(Kmt.Text)), Trim(UCase(ChrConv(TextBox1.Text))), "")) Then myFlag = True
        If myFlag = True Then
            myK1 = I: Kmt.Parent.Select
            userform1.Caption = "TROVATO in commento"
'>>
            If Me.CheckBox3 = True Then CompilaLR1 (Selection.Row)
            Exit Sub
        End If
    End If
Next
'
FineKmt:
userform1.Caption = "------> FINE RICERCA"
'>>
If myListI > 0 Then
    ReDim Preserve myListREs(1 To 5, 1 To myListI)
    UserForm2.Show
End If
Set myPrimo = Nothing ': GoTo RAvvia
End Sub

Devi sostituire in toto le macro elencate sopra; le zone modificate sono identificate da >>.

Vai sullo stesso Modulo in cui avevi inserito la Function splip e la Function ComPar:
-in testa, aggiungi
Codice: Seleziona tutto
Public myListREs(), myListI As Long

-in coda aggiungi
Codice: Seleziona tutto
Function CompilaLR1(ByVal CRow As Long)
'>>
Dim myCols, I As Long, J As Long
'
myListI = myListI + 1
If ActiveSheet.Name = "archivio" Then
    If Selection.Column = 1 Or Selection.Column = 2 Then myCols = Array("A", "B", "C", "D")
    If Selection.Column = 28 Then myCols = Array("AB", "AC", "AD")
Else
    If Selection.Column = 1 Or Selection.Column = 2 Then myCols = Array("A", "E", "H", "I", "J")
End If
'aaa = UBound(myListREs, 2)
For I = LBound(myCols, 1) To UBound(myCols, 1)
    J = J + 1
    myListREs(J, myListI - 0) = ActiveSheet.Cells(CRow, myCols(I))
Next I
End Function

A questo punto... prova e dimmi se sei fortunato.

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

Re: cerca nomi

Postdi trittico69 » 03/07/12 19:42

a questo punto mi sono perso
ti metto i vari codici ma misa che ho fatto un pasticcio
Codice: Seleziona tutto
Dim myPrimo As Range, myCorr As Range, myK1 As Long 'questo codice cerca nel foglio archivio e usciti sia nelle celle che nei commenti




Private Sub CheckBox2_Click()
'>>
Set myPrimo = Nothing: myListI = 0
TextBox1.SetFocus
End Sub

Private Sub CommandButton2_Click()
Sheets("Archivio").Select
TextBox1.SetFocus
'>>
Set myPrimo = Nothing: myListI = 0
End Sub

Private Sub CommandButton3_Click()
Sheets("usciti").Select
TextBox1.SetFocus
'>>
Set myPrimo = Nothing: myListI = 0
End Sub

Private Sub UserForm_initialize()
'>>
ReDim myListREs(1 To 5, 1 To 1)
CommandButton1.Caption = "trova": CommandButton1.Accelerator = "T": CommandButton1.Default = True
userform1.Caption = "cerca"
End Sub

Private Sub CheckBox3_Change()
'>>
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
End Sub

Private Sub CommandButton1_Click()
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=95607
'opzione ricerca per parola PIU' CONVERSIONE LETTERE
'CheckBox3 per eventuale riepilogo su Form2; vedi modifiche marcate >>
'
Dim I As Long
'>>
NextUB = UBound(myListREs, 2) + 1
ReDim Preserve myListREs(1 To 5, 1 To NextUB)

'
If myPrimo Is Nothing Then myCellFound = 0: Set myCorr = Nothing
'
RAvvia:
userform1.Caption = "CERCA in cella"
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
'
myArea = "AB3:AB100, A3:B2000"
If Not myCorr Is Nothing Then GoTo CkCmt
myFlag = 0
For Each myCell In ActiveSheet.Range(myArea)
If myCell.Value <> "" Then
If CheckBox2.Value And ComPar(ChrConv(myCell.Value), (TextBox1.Text)) Then myFlag = True
If CheckBox2.Value = False And Len(UCase(ChrConv(myCell.Value))) > Len(Replace(UCase(ChrConv(myCell.Value)), Trim(UCase(ChrConv(TextBox1.Text))), "")) Then myFlag = True
aaa = myCell.Value
If myFlag = True Then
CellFound = CellFound + 1
myFlag = 0
If CellFound > myCellFound Then
Set myPrimo = myCell: myK1 = 0
myCellFound = myCellFound + 1
userform1.Caption = "TROVATO in cella"
myCell.Select
'>>
If Me.CheckBox3 = True Then CompilaLR1 (Selection.Row)
Exit Sub
End If
End If
End If
Next myCell

GoTo CkCmt

'
CkCmt:
Set myCorr = ActiveCell
userform1.Caption = "CERCA in commento"
If myPrimo Is Nothing Then Set myPrimo = ActiveCell
If myCorr Is Nothing Then Set myCorr = Range("A1")
'myK1 = 0
For I = myK1 + 1 To ActiveSheet.Comments.Count
Set Kmt = ActiveSheet.Comments(I)
If Not Application.Intersect(Kmt.Parent, Range(myArea)) Is Nothing Then
myFlag = 0
If CheckBox2.Value = True And ComPar(ChrConv(Kmt.Text), ChrConv(TextBox1.Text)) Then myFlag = True
If CheckBox2.Value = False And Len(UCase(ChrConv(Kmt.Text))) > Len(Replace(UCase(ChrConv(Kmt.Text)), Trim(UCase(ChrConv(TextBox1.Text))), "")) Then myFlag = True
If myFlag = True Then
myK1 = I: Kmt.Parent.Select
userform1.Caption = "TROVATO in commento"
'>>
If Me.CheckBox3 = True Then CompilaLR1 (Selection.Row)
Exit Sub
End If
End If
Next
'
FineKmt:
userform1.Caption = "------> FINE RICERCA"
'>>
If myListI > 0 Then
ReDim Preserve myListREs(1 To 5, 1 To myListI)
UserForm2.Show
End If
Set myPrimo = Nothing ': GoTo RAvvia
End Sub



'Private Sub CommandButton2_Click() 'questo codice è collegato al tasto presenti della fom e permette di cercare i nomi nel foglio archivio
'Sheets("Archivio").Select
'TextBox1.SetFocus 'permette di poter scrivere direttamente il nome da cercare senza fare click nella finestra
'Set myPrimo = Nothing
'End Sub

'Private Sub CommandButton3_Click() 'questo codice è collegato al tasto usciti della fom e permette di cercare i nomi nel foglio usciti
'Sheets("usciti").Select
'TextBox1.SetFocus
'Set myPrimo = Nothing
'End Sub
Private Sub CommandButton4_Click() 'questo codice è collegato al tasto colleghi della fom e permette di cercare i nomi nel foglio colleghi
Sheets("colleghi").Select
TextBox1.SetFocus
Set myPrimo = Nothing
End Sub
'Private Sub CheckBox2_Click()
'Set myPrimo = Nothing
'TextBox1.SetFocus
'End Sub
Private Sub TextBox1_Change()
Set myPrimo = Nothing
End Sub
Private Sub UserForm_Activate()
TextBox1.SetFocus
End Sub
'Private Sub UserForm_initialize()
'CommandButton1.Caption = "trova": CommandButton1.Accelerator = "T": CommandButton1.Default = True
'userform1.Caption = "cerca"
'End Sub]


Codice: Seleziona tutto
Public myListREs(), myListI As Long
Function CompilaLR1(ByVal CRow As Long)
'>>
Dim myCols, I As Long, J As Long
'
myListI = myListI + 1
If ActiveSheet.Name = "archivio" Then
If Selection.Column = 1 Or Selection.Column = 2 Then myCols = Array("A", "B", "C", "D")
If Selection.Column = 28 Then myCols = Array("AB", "AC", "AD")
Else
If Selection.Column = 1 Or Selection.Column = 2 Then myCols = Array("A", "E", "H", "I", "J")
End If
'aaa = UBound(myListREs, 2)
For I = LBound(myCols, 1) To UBound(myCols, 1)
J = J + 1
myListREs(J, myListI - 0) = ActiveSheet.Cells(CRow, myCols(I))
Next I
End Function

Dim mySplip
Function splip(ByVal mySorg As String)
mySplip = Split(UCase(mySorg), " ")
splip = UBound(mySplip)
End Function

Function ComPar(ByVal myCell As String, ByVal myText As String) As Boolean
NumPar = splip(myCell)
For I = 0 To NumPar
    If mySplip(I) = Trim(UCase(myText)) Then ComPar = True: Exit Function
Next I
End Function


Option Explicit
Public sh1 As Worksheet, sh2 As Worksheet, x As Long, y As Long, z As Long

Sub avvia()
Sheets("presenti").Select
 Range("A2").Select ' aggiorna dati esterni del foglio presenti
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("E2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("I2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("M2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("Q2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("U2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("Y2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("AC2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("AG2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("AK2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("AO2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("AS2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("AW2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("BA2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("BE2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("BI2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("BM2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("BQ2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("BU2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("BY2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("CC2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("CG2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("CK2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("CO2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("CS2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("Cw2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("da2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("de2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("di2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("dm2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Sheets("usciti").Select
    Range("a2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    Range("e2").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False

Sheets("I").Select ' seleziona A5-B5-C5 di tutte le sezioni e trascina giu per eliminare errori
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
    Range("A5:C92").Select
    Sheets("II").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
    Range("A5:C92").Select
    Sheets("III").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
    Range("A5:C92").Select
    Sheets("IV").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
    Range("A5:C92").Select
    Sheets("V").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
    Range("A5:C92").Select
    Sheets("VI").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
    Range("A5:C92").Select
    Sheets("VII").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
    Range("A5:C92").Select
    Sheets("VIII").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C92"), Type:=xlFillDefault
    Range("A5:C92").Select
    Sheets("IX").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C89"), Type:=xlFillDefault
    Range("A5:C89").Select
    Sheets("X").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C90"), Type:=xlFillDefault
    Range("A5:C90").Select
    Sheets("XI").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C89"), Type:=xlFillDefault
    Range("A5:C89").Select
    Sheets("XII").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C89"), Type:=xlFillDefault
    Range("A5:C89").Select
    Sheets("XIII").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C89"), Type:=xlFillDefault
    Range("A5:C89").Select
    Sheets("C.CL.").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C50"), Type:=xlFillDefault
    Range("A5:C50").Select
    Range("A51:C51").Select
    Selection.AutoFill Destination:=Range("A51:C70"), Type:=xlFillDefault
    Range("A51:C70").Select
    Range("A71:C71").Select
    Selection.AutoFill Destination:=Range("A71:C120"), Type:=xlFillDefault
    Range("A71:C120").Select
    Range("A121:C121").Select
    Selection.AutoFill Destination:=Range("A121:C140"), Type:=xlFillDefault
    Range("A121:C140").Select
    Range("A141:C141").Select
    Selection.AutoFill Destination:=Range("A141:C150"), Type:=xlFillDefault
    Range("A141:C150").Select
    Range("A151:C151").Select
    Selection.AutoFill Destination:=Range("A151:C170"), Type:=xlFillDefault
    Range("A151:C170").Select
    Range("A171:C171").Select
    Selection.AutoFill Destination:=Range("A171:C210"), Type:=xlFillDefault
    Range("A171:C210").Select
    Range("A211:C211").Select
    Selection.AutoFill Destination:=Range("A211:C240"), Type:=xlFillDefault
    Range("A211:C240").Select
    Range("A241:C241").Select
    Selection.AutoFill Destination:=Range("A241:C290"), Type:=xlFillDefault
    Range("A241:C290").Select
    Range("A345:C345").Select
    Selection.AutoFill Destination:=Range("A345:C466"), Type:=xlFillDefault
    Range("A345:C466").Select
    Range("A347:C347").Select
    Selection.AutoFill Destination:=Range("A347:C497"), Type:=xlFillDefault
    Range("A347:C497").Select
    Range("A498:C498").Select
    Selection.AutoFill Destination:=Range("A498:C599"), Type:=xlFillDefault
    Range("A498:C599").Select
    Range("A600:C600").Select
    Selection.AutoFill Destination:=Range("A600:C699"), Type:=xlFillDefault
    Range("A600:C699").Select
    Range("A700:C700").Select
    Selection.AutoFill Destination:=Range("A700:C739"), Type:=xlFillDefault
    Range("A700:C739").Select
    Range("A740:C740").Select
    Selection.AutoFill Destination:=Range("A740:C769"), Type:=xlFillDefault
    Range("A740:C769").Select
    Range("A770:C770").Select
    Selection.AutoFill Destination:=Range("A770:C800"), Type:=xlFillDefault
    Range("A770:C800").Select
    Sheets("Transex").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C32"), Type:=xlFillDefault
    Range("A5:C32").Select
    Sheets("TR1").Select
    Range("A5:C5").Select
    Selection.AutoFill Destination:=Range("A5:C61"), Type:=xlFillDefault
    Range("A5:C61").Select
    Sheets("TR2").Select
    Range("A5:D5").Select
    Selection.AutoFill Destination:=Range("A5:D34"), Type:=xlFillDefault
    Range("A5:D34").Select
   
Dim r As Long 'controlla i cambiamenti tra foglio"archivio" e tutti i fogli delle sezioni
Dim rr As Long
Dim G As Long
Dim K As Long
Dim l As Variant
Dim n As String
Dim p As Variant
Dim nn As Variant
Dim rg As Long
Dim trovato As Boolean
Dim dat(1 To 3)
Set sh1 = Worksheets("Archivio")
sh1.Activate
Application.EnableEvents = False
rg = Cells(Rows.Count, 15).End(xlUp).Row + 1
Range(Cells(3, 5), Cells(rg, 6)).ClearContents
Range(Cells(3, 15), Cells(rg, 15)).ClearContents
G = Cells(Rows.Count, 7).End(xlUp).Row + 1
Range(Cells(3, 7), Cells(G, 10)).ClearContents
K = Cells(Rows.Count, 11).End(xlUp).Row + 1
Range(Cells(3, 11), Cells(K, 14)).ClearContents
'Application.ScreenUpdating = False''non fa vedere i passaggi dei controlli sezione per sezione se togli le virgolette lo attivi'
G = 3
K = 3
For x = 1 To 18
  Sheets(x).Select
  rg = Cells(Rows.Count, 1).End(xlUp).Row
  n = Sheets(x).Name
  Set sh2 = Worksheets(n)
  Select Case n
    Case "I": p = 1 'assegna alla sezione il numero normale anzichè il numero romano'
    Case "II": p = 2
    Case "III": p = 3
    Case "IV": p = 4
    Case "V": p = 5
    Case "VI": p = 6
    Case "VII": p = 7
    Case "VIII": p = 8
    Case "IX": p = 9
    Case "X": p = 10
    Case "XI": p = 11
    Case "XII": p = 12
    Case "XIII": p = 13
    Case "Transex": p = "D"
    Case "TR1": p = "TR1"
    Case "TR2": p = "TR2"
    Case "FEMMINILE": p = "F"
  End Select
  For y = 5 To rg
    If Cells(y, 2) = "" Or Cells(y, 2) = 0 Then
      GoTo 10
    Else
      If Cells(y, 1) <> "" Then
        If n = "C.CL." Then 'nel foglio centro clinico...'
          Select Case y
            Case 5 To 50: p = "DEG." 'le celle da 5 a 11 è reparto ?'
            Case 51 To 70: p = "OSS."
            Case 71 To 120: p = "EXD."
            Case 121 To 140: p = "I.S."
            Case 141 To 150: p = "M"
            Case 151 To 170: p = "FXG"
            Case 171 To 210: p = "PER"
            Case 211 To 240: p = "R.O."
            Case 241 To 290: p = ""
            Case 291 To 344: p = "ITO"
            Case 345 To 466: p = "?"
            Case 467 To 800: p = "F"
          End Select
        End If
        If IsNumeric(Cells(y, 1)) Then l = Val(Cells(y, 1)) Else l = Cells(y, 1)
      End If
      dat(1) = l
      dat(2) = Cells(y, 2)
      dat(3) = Cells(y, 3)
    End If
    rr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    For z = 2 To rr
      If sh1.Cells(z, 1) = dat(2) And sh1.Cells(z, 2) = dat(3) Then trovato = True: r = z: Exit For
    Next z
    If trovato = True Then
      If sh1.Cells(r, 3) = p And sh1.Cells(r, 4) = dat(1) Then
        sh1.Cells(r, 15) = 1
      Else
        sh1.Cells(r, 5) = p
        sh1.Cells(r, 6) = dat(1)
        sh1.Cells(r, 15) = 1
      End If
    End If
    If trovato = False Then
      r = rr + 1
      sh1.Cells(r, 1) = dat(2)
      sh1.Cells(r, 2) = dat(3)
      sh1.Cells(r, 3) = p
      sh1.Cells(r, 4) = dat(1)
      sh1.Cells(G, 7) = dat(2)
      sh1.Cells(G, 8) = dat(3)
      sh1.Cells(G, 9) = p
      sh1.Cells(G, 10) = dat(1)
      sh1.Cells(r, 15) = 0
      G = G + 1
    End If
    trovato = False
10:
  Next y
Next x
sh1.Activate
r = Cells(Rows.Count, 15).End(xlUp).Row
For x = 3 To r
  If x = r Then Exit For
  If Cells(x, 15) = "" Then
    Cells(K, 11) = Cells(x, 1)
    Cells(K, 12) = Cells(x, 2)
    Cells(K, 13) = Cells(x, 3)
    Cells(K, 14) = Cells(x, 4)
    Range(Cells(x, 1), Cells(x, 6)).Select
    Selection.Delete shift:=xlUp
    Cells(x, 15).Select
    Selection.Delete shift:=xlUp
    x = x - 1
    r = r - 1
    K = K + 1
  End If
Next x
Range("A2:F2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("E3"), Order1:=xlAscending, Key2:=Range("A3") _
  , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
  False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
  :=xlSortNormal
r = Cells(Rows.Count, 5).End(xlUp).Row
Range("A2:F" & r).Select ' ordia alfabetico i movimenti'
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlYes, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal
Range("G2:J2").Select 'ordina alfabetico gli entrati'
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("G3"), Order1:=xlAscending, Header:=xlYes, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal
Range("k2:N2").Select 'ordina alfabetico gli usciti'
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("K3"), Order1:=xlAscending, Header:=xlYes, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
  DataOption1:=xlSortNormal
Range("A3").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
Sheets("archivio").Select
   
   
   
    Application.DisplayAlerts = False ' copia i nominativi dal foglio archivio al fogli stampa i moviment
    Sheets("archivio").Select
    Range("A1:r400").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("stampa movimenti").Select
    Range("A1:B1").Select
    ActiveSheet.Paste
Application.DisplayAlerts = True
Range("A1:R972").Select
    Application.CutCopyMode = False
    Selection.Interior.ColorIndex = xlNone
   

'Sub sta1()
Dim rt As Long
Dim r1 As Long
Dim st As String
Dim cp As Long
Dim d As Long
Dim ind As Variant
Dim rrt As Long
Dim rrtt As Long
Dim rrttt As Long
'ELIMINA GLI ENTRATI E GLI USCITI CHE VENGONO RINOMINATI PERCHE' IL NOME SBAGLIATO E FINISCE A FINE 7
Dim Gt As Range, KK As Range, cl3 As Object, cl4 As Object, _
xx As Long, yy As Long, zt As Long, xt As Long, _
yt As Long, zz As Long, xtt As Long, xttt As Long
Set Gt = Range("G3:G1500")
Set KK = Range("K3:K1500")
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'AMMETTENDO CHE LA RIGA 1 è OCCUPATA DALLE INTESTAZIONI DI COLONNA
'EFFETTUO UN CICLO PER TROVARE LA PRIMA CELLA OCCUPATA DELLA COLONNA G;
'IN OGNI CASO PUOI MODIFICARE IL RANGE G e K EDITANDO LE VARIABILI SOPRA (Set)
For Each cl3 In Gt
If cl3 = "" Then
    cl3.Select
    xt = Selection.Row
    Exit For
    'If cl3 <> "" Then
    Else
        cl3.Select
        xt = Selection.Row
'xt è IL NUMERO RIGA DELLA PRIMA CELLA OCCUPATA DELLA COLONNA G
        Exit For
    End If
Next
If cl3 = "" Then
    yt = Cells(1500, 7).End(xlUp).Row + 1
    Else
        yt = Cells(1500, 7).End(xlUp).Row
End If
'yt è IL NUMERO RIGA DELL'ULTIMA CELLA OCCUPATA DELLA COLONNA G
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'EFFETTUO UN CICLO PER TROVARE LA PRIMA CELLA OCCUPATA DELLA COLONNA K
For Each cl4 In KK
If cl4 = "" Then
    cl4.Select
    xx = Selection.Row
    Exit For
    'If cl4 <> "" Then
    Else
        cl4.Select
        xx = Selection.Row
'xx è IL NUMERO RIGA DELLA PRIMA CELLA OCCUPATA DELLA COLONNA K
        Exit For
    End If
Next
If cl4 = "" Then
    yy = Cells(1500, 11).End(xlUp).Row + 1
    Else
        yy = Cells(1500, 11).End(xlUp).Row
End If
'yy è IL NUMERO RIGA DELL'ULTIMA CELLA OCCUPATA DELLA COLONNA K
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'DOPPIO CICLO FOR/NEXT PER CONTROLLARE OGNI RIGA OCCUPATA DELLE
'COLONNE G-H-I-J CON OGNI RIGA OCCUPATA DELLE COLONNE K-L-M-N
For zt = xt To yt
    For zz = xx To yy
        If Cells(zt, 9) = Cells(zz, 13) And Cells(zt, 10) = Cells(zz, 14) _
        And (Cells(zt, 7) = Cells(zz, 11) Or Cells(zt, 8) = Cells(zz, 12)) Then
            Range(Cells(zt, 7), Cells(zt, 10)).ClearContents
            Range(Cells(zz, 11), Cells(zz, 14)).ClearContents
        End If
    Next zz
Next zt
 'FINE 7


Dim cl, cl2, rng, RNG2, NOME, COGNOME ' CANCELLA I CAMBIAMENTI DI CELLA DEL CCL TR1 TR2 F D IL CODICE FINISCE DOV'è SCRITTO FINE2
rt = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim Condizioni As New Collection
Condizioni.Add "F|F"
Condizioni.Add "D|D"
Condizioni.Add "TR1|TR1"
Condizioni.Add "TR2|TR2"
Condizioni.Add "TR2|TR1"
Condizioni.Add "TR1|TR2"
Condizioni.Add "OSS.|OSS."
Condizioni.Add "I.S.|I.S."
Condizioni.Add "EXD.|EXD."
Condizioni.Add "DEG.|DEG."
Condizioni.Add "DEG.|OSS."
Condizioni.Add "DEG.|EXD."
Condizioni.Add "DEG.|I.S."
Condizioni.Add "OSS.|EXD."
Condizioni.Add "OSS.|I.S."
Condizioni.Add "OSS.|DEG."
Condizioni.Add "EXD.|DEG."
Condizioni.Add "EXD.|OSS."
Condizioni.Add "EXD.|I.S."
Condizioni.Add "I.S.|EXD."
Condizioni.Add "I.S.|OSS."
Condizioni.Add "I.S.|DEG."
ReDim c(rt) As Integer
Dim I, J, Kt, cond
Set RNG2 = Range("C3:E" & rt)
For Each cl2 In RNG2
    For Each cond In Condizioni
        If cl2.Offset(0, 0) = Split(cond, "|")(0) And cl2.Offset(0, 2) = Split(cond, "|")(1) Then
        I = I + 1
        c(I) = cl2.Row
     End If
    Next
Next
Kt = I
Sheets("stampa movimenti").Select
For I = 1 To Kt
   ActiveSheet.Range("A1:F1").Offset(c(I) - 1, 0).Delete
For J = I + 1 To Kt
    c(J) = c(J) - 1
   Next
Next 'FINE2


rrt = Range("I" & Rows.Count).End(xlUp).Row 'cancella nella colonna entrati il femminile tr1 e tr2 il codice finisce a fine 5
    For xt = 3 To rrt
        If Cells(xt, "I") = "F" Or Cells(xt, "I") = "TR1" Or Cells(xt, "I") = "TR2" Then
            Range("G" & xt & ":" & "J" & xt).ClearContents
        End If
    Next xt 'fine 5
   
rrtt = Range("E" & Rows.Count).End(xlUp).Row 'cancella nella colonna movimenti i fuori per giustizia i detenuti da prendere in carico(?)i permessi e ricovero finisce a fine 6
    For xtt = 3 To rrtt
        If Cells(xtt, "E") = "PER" Or Cells(xtt, "E") = "FXG" Or Cells(xtt, "E") = "R.O." Or Cells(xtt, "E") = "?" Then
            Range("A" & xtt & ":" & "F" & xtt).ClearContents
        End If
    Next xtt
    rrttt = Range("C" & Rows.Count).End(xlUp).Row
    For xttt = 3 To rrttt
        If Cells(xttt, "C") = "PER" Or Cells(xttt, "C") = "FXG" Or Cells(xttt, "C") = "R.O." Or Cells(xttt, "C") = "?" Then
            Range("A" & xttt & ":" & "F" & xttt).ClearContents
        End If
    Next xttt 'fine 6
   
Range("A3:F" & rt).Select 'ordina alfabetico colonna movimenti
    Selection.Sort Key1:=Range("E3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Range("G3:J1700").Select 'ordina alfabetico colonna entrati
    Selection.Sort Key1:=Range("G3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Range("K3:N1700").Select ' ordina alfabetico colonna usciti
    Selection.Sort Key1:=Range("K3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("G8").Select
Set sh1 = Worksheets("stampa movimenti")
sh1.Activate
Application.ScreenUpdating = False
st = Cells(2, 16)
cp = Cells(2, 17)
Cells(1, 18) = Cells(Rows.Count, 5).End(xlUp).Row
r1 = Cells(1, 18)
Cells(1, 19) = Cells(Rows.Count, 7).End(xlUp).Row
Cells(1, 20) = Cells(Rows.Count, 11).End(xlUp).Row
Cells(2, 18).Select
ActiveCell.FormulaR1C1 = "=LARGE(R[-1]C:R[-1]C[2],1)"
rt = Cells(2, 18)
Range(Cells(1, 18), Cells(2, 20)).ClearContents
If r1 < rt Then
  If r1 = 2 Then
    Range(Cells(r1 + 1, 1), Cells(rt, 4)).Select
    Selection.Insert shift:=xlDown
    Cells(4, 5).Copy
    Range(Cells(r1 + 1, 1), Cells(rt, 4)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
  Else
    Range(Cells(r1 + 1, 1), Cells(rt, 6)).Select
    Selection.Insert shift:=xlDown
  End If
End If
If r1 < rt Then d = rt Else d = r1
Range("A3:F" & d).Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess
For xt = 3 To d Step 2
  Range(Cells(xt, 1), Cells(xt, 14)).Interior.ColorIndex = 45 ' colora di arancione un rigo si e uno no
Next xt
Range("A3:N" & r).Select 'seleziona l'area di stampa'
ind = Range("A3:N" & rt).Address
ActiveSheet.PageSetup.PrintArea = ind
With ActiveSheet.PageSetup
  .PrintTitleRows = "$1:$2"
  .PrintTitleColumns = ""
End With
With ActiveSheet.PageSetup
  .LeftHeader = "Stampato in Data &D - &T   Pagine &P/&N" 'stampa data ora e numero di pagine'
  .CenterHeader = "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & _
    "&""Arial,Grassetto Corsivo""&18Direzione N.C.P. Solliciano - Firenze&""Arial,Normale""&10" & Chr(10) & _
"&""Arial,Grassetto Corsivo""&12Variazioni Celle, Nuovi Arrivi, Uscite, in Data &D" 'intestazione pagina'
  .LeftMargin = Application.InchesToPoints(0.1) 'margine sinistro della stampa'
  .RightMargin = Application.InchesToPoints(0.1) 'margine destro'
  .TopMargin = Application.InchesToPoints(1.6) 'margine alto'
  .BottomMargin = Application.InchesToPoints(0.25) 'adatta lo scritto alla pagina della stampa'
  .HeaderMargin = Application.InchesToPoints(0.1) 'abbassa o alza il titolo della pagina di stampa'
  .FooterMargin = Application.InchesToPoints(0.2) 'abbassa o alza lo scritto sotto la pagine'
  .PrintHeadings = False
  .PrintGridlines = False
  .PrintComments = xlPrintNoComments
  .CenterHorizontally = False
  .CenterVertically = False
  .Orientation = xlLandscape 'stampa in verticale...per stampare in orizzontale sostituisci con =x1portrait'
  .Draft = False
  .PaperSize = xlPaperA4 'tipo di foglio usati per la stampa'
  .FirstPageNumber = xlAutomatic
  .Order = xlDownThenOver
  .BlackAndWhite = False
  .Zoom = 100 'ingrandisce o rimpiccolisce la stampa'
  .PrintErrors = xlPrintErrorsDisplayed
End With
Application.ScreenUpdating = True
If st = "V" Then ActiveWindow.SelectedSheets.PrintPreview
If st = "S" Then ActiveWindow.SelectedSheets.PrintOut Copies:=cp
If r1 < rt Then
Range(Cells(r1 + 1, 1), Cells(rt, 4)).Select
  Selection.Delete shift:=xlUp
End If
Cells(2, 1).Select
Sheets("archivio").Select
   

'Sub aggiorna1() 'aggiorna i nominativi, movimenti, entrati e usciti
Dim Gh As Long
Dim Kh As Long
Set sh1 = Worksheets("Archivio")
sh1.Activate
Gh = Cells(Rows.Count, 7).End(xlUp).Row + 1
Range(Cells(3, 7), Cells(Gh, 10)).ClearContents
Kh = Cells(Rows.Count, 11).End(xlUp).Row + 1
Range(Cells(3, 11), Cells(Kh, 14)).ClearContents
For x = 3 To Cells(Rows.Count, 1).End(xlUp).Row
  If Cells(x, 5) <> "" Then
    Cells(x, 3) = Cells(x, 5)
    Cells(x, 4) = Cells(x, 6)
    Cells(x, 5) = ""
    Cells(x, 6) = ""
  End If
Next x
Cells(2, 1).Select
    Range("A3:F1516").Select 'ordina alfabetico tutti i nomi'
    Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
          Sheets("Archivio").Select
    Range("AB3").Select
    Selection.AutoFill Destination:=Range("AB3:AB247"), Type:=xlFillDefault
    Range("AB3:AB247").Select
        ActiveWorkbook.Save
        Application.Run "'rubricagedet.xls'!trova1"
     End Sub
     
Sub trova1() 'rende visibile la finestra per cercare i nomi
If userform1.Visible = False Then userform1.Show False
userform1.Left = 345 'coordinate dove far apparire la finestra destra sinistra
userform1.Top = 200
End Sub




e infine il codice della seconda userfrom
Codice: Seleziona tutto
Private Sub UserForm_Activate()
Me.ListBox1.ColumnCount = 5
Me.ListBox1.ColumnHeads = True
Me.ListBox1.List() = Application.WorksheetFunction.Transpose(myListREs())
End Sub


provandolo mi da sub o valora non definito e mi evidenzia
(ChrConv...
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi Anthony47 » 03/07/12 22:48

La "funzione" ChrConv fu rilasciata per gestire la ricerca di caratteri accentati e altro; dovrebbe trovarsi nello stesso "Modulo" dove hai inserito le funzioni Splip e ComPar, come avevo descritto qui: viewtopic.php?f=26&t=95607&p=550748#p549984

Nel tuo elenco di codici trovo la Splip, trovo la ComPar, trovo l' ultima aggiunta CompilaLR1 ma non trovo la ChrConv; direi quindi che te la sei dimenticata.

Tra l' altro non hai indicato su quali "moduli" si trovano le varie macro, non so quindi valutare se le "dichiarazioni" comuni a piu' macro sono correttamente in testa al modulo; in particolare Dim mySplip dovrebbe trovarsi in testa al modulo che contiene la Function Splip e la Function ComPar.

Se non risolvi con queste indicazioni forse e' meglio che pubblichi il file come l' hai composto.

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

Re: cerca nomi

Postdi trittico69 » 04/07/12 17:33

te l'ho inviato tramite messaggio privato
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi Anthony47 » 04/07/12 21:56

Il file e', nella parte che ci interessa, sostanzialmente simile a quelli che avevi gia' pubblicato.

Ci sono pero' vari errori che ho corretto e in piu' ho fatto alcune modifiche per gestire casi che non avevo collaudato. In dettaglio:
In Modulo4, nella Function ChrConv mancavano due righe in fondo:
Codice: Seleziona tutto
Next I
ChrConv = myConvers  '<<Mancava
End Function         '<<Mancava
'
Function CompilaLR1(ByVal CRow As Long)   'Inizio della macro successiva

La macro Private Sub UserForm_Activate() di userform2 aveva il nome sbagliato (UserForm_Activte); inoltre ci sono due End Sub, ovviamente una va eliminata.

Ho sostituito la Private Sub CommandButton1_Click() come detto nella risposta datata 3-7-2012 "mattina", vedi : viewtopic.php?f=26&t=95607&start=20#p550701 (e' all' interno del secondo blocco di codice).

Nella Function CompilaLR1 (Modulo4) devi indicare esattamente il nome del foglio; quindi se il foglio si chiama "Archivio" (e non "archivio") devi modificare in
Codice: Seleziona tutto
If ActiveSheet.Name = "Archivio" Then


Nella stessa Function CompilaLR1 (Modulo4), avevo erroneamente dimenticato una delle possibili colonne usate nella ricerca; va quindi aggiunta una riga, cioe' invece di
Else
If Selection.Column = 1 Or Selection.Column = 2 Then myCols = Array("A", "E", "H", "I", "J")
End If

devi modificare in
Else
If Selection.Column = 1 Or Selection.Column = 2 Then myCols = Array("A", "E", "H", "I", "J")
If Selection.Column = 28 Then myCols = Array("AB", "AC", "AD") '<< Aggiungere
End If


Inoltre poteva verificarsi un errore con alcune situazioni operative, per cui ho modificato una riga nella Private Sub UserForm_initialize() di userform1, da ReDim myListREs(1 To 5, 1 To 1)
a
ReDim myListREs(1 To 5, 1 To 1): myListI = 0

Infine nella Sub CommandButton1_Click di userform1 ho aggiunto in coda questa riga per resettare il contenuto della seconda userform:
Codice: Seleziona tutto
Set myPrimo = Nothing ': GoTo RAvvia
ReDim myListREs(1 To 5, 1 To 1): myListI = 0    '<< AGGIUNTA
End Sub

Riprova con queste modifiche...

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

Re: cerca nomi

Postdi trittico69 » 05/07/12 19:54

ma potevi mandarmi il file modificato in questo modo facciamo due volte lo stesso lavoro...aspetto una tua risposta.ciao!
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

Re: cerca nomi

Postdi Anthony47 » 07/07/12 02:21

ma potevi mandarmi il file modificato in questo modo facciamo due volte lo stesso lavoro...aspetto una tua risposta.ciao!
Beh, se e' per questo io l' ho fatto ben piu' di due volte il lavoro...

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

Re: cerca nomi

Postdi trittico69 » 07/07/12 06:26

ok provo da solo e ti faccio sapere
trittico69
Utente Senior
 
Post: 497
Iscritto il: 16/08/09 18:41

PrecedenteProssimo

Torna a Applicazioni Office Windows


Topic correlati a "cerca nomi":


Chi c’è in linea

Visitano il forum: Nessuno e 68 ospiti