Moderatori: Anthony47, Flash30005
=SE((PICCOLO(CONTA.SE(SCARTO(elenconomi;0;0;RIF.RIGA(INDIRETTO("1:"&RIGHE(elenconomi)));1);elenconomi)+RIF.RIGA(elenconomi)/10000;RIF.RIGA(A1)))<2;SCARTO(SCARTO(elenconomi;0;0;1;1);CONFRONTA(PICCOLO(CONTA.SE(SCARTO(elenconomi;0;0;RIF.RIGA(elenconomi)-RIF.RIGA(SCARTO(elenconomi;0;0;1;1))+1;1);elenconomi)+RIF.RIGA(elenconomi)/10000;RIF.RIGA(A1));CONTA.SE(SCARTO(elenconomi;0;0;RIF.RIGA(INDIRETTO("1:"&RIGHE(elenconomi)));1);elenconomi)+RIF.RIGA(elenconomi)/10000;0)-1;0);"")
Flash30005 ha scritto:Questa formula fu postata da Anthony e te la ripropongo
Seleziona Le celle Da N20 a Nx (anche oltre) e definisci un nome
Da Menu Inserisci -> Definisci -> Nome
darai nome Elenconomi (ad esempio)
poi nella testata in N2
scriverai questa formula
- Codice: Seleziona tutto
=SE((PICCOLO(CONTA.SE(SCARTO(elenconomi;0;0;RIF.RIGA(INDIRETTO("1:"&RIGHE(elenconomi)));1);elenconomi)+RIF.RIGA(elenconomi)/10000;RIF.RIGA(A1)))<2;SCARTO(SCARTO(elenconomi;0;0;1;1);CONFRONTA(PICCOLO(CONTA.SE(SCARTO(elenconomi;0;0;RIF.RIGA(elenconomi)-RIF.RIGA(SCARTO(elenconomi;0;0;1;1))+1;1);elenconomi)+RIF.RIGA(elenconomi)/10000;RIF.RIGA(A1));CONTA.SE(SCARTO(elenconomi;0;0;RIF.RIGA(INDIRETTO("1:"&RIGHE(elenconomi)));1);elenconomi)+RIF.RIGA(elenconomi)/10000;0)-1;0);"")
conferma con CTRL+Maiu+Enter
Trascini fino a N10 (sperando che non siano più di 9 i nomi univoci nell'elenco)
Avrai un elenco di nomi univoci
Ciao
Anthony47 ha scritto:La formula sara' certamente perfettisima, ma in alternativa potresti usare Filtro avanzato: Selezione i dati di origine, tab Dati, Ordina e filtra, Avanzato; spunti Copia univoca dei record, selezioni Copia in altra posizione e indichi la destinazione.
Ciao
=SE.ERRORE(INDICE(elenconomi;PICCOLO(RIF.RIGA(elenconomi)+10000*(CONTA.SE(SCARTO(elenconomi;0;0;RIF.RIGA(INDIRETTO("1:"&RIGHE(elenconomi)));1);elenconomi)<>1);RIF.RIGA(A1)));"")
=Se(Val.Errore(LaFormula);"";LaFormula)
=Se.Errore(LaFormula;"")
Private Sub Worksheet_Change(ByVal Target As Range)
CheckArea = "N20:N100" '<<< Adattare
If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then Exit Sub
Application.EnableEvents = False
Call MacroAdvancedFiltro
Application.EnableEvents = True
End Sub
Flash30005 ha scritto:Sicuramente non è stato fatto tutto a dovere
ti invio questo file come test
ciao
Anthony47 ha scritto:Usando il metodo del filtro avanzato, registra la macro che esegue il filtro avanzato; poi inserisci questo codice nel modulo di codice del foglio su cui lavori:Dal foglio excel, tasto dx sul tab col nome del foglio; scegli Visualizza codice, copia la macro e incollala nel frame di dx.
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
CheckArea = "N20:N100" '<<< Adattare
If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then Exit Sub
Application.EnableEvents = False
Call MacroAdvancedFiltro
Application.EnableEvents = True
End Sub
Ciao
Sub NomiUnivoci()
Range("N20:N150").Copy Destination:=Range("IV20")
Range("N2:N19").ClearContents
Range("IV20:IV150").Select
Selection.Sort Key1:=Range("IV20"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
UR = Range("IV" & Rows.Count).End(xlUp).Row
Range("IV20:IV" & UR).Select
Range("IV20:IV" & UR).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
UR2 = Range("IV" & Rows.Count).End(xlUp).Row
Range("IV20:IV" & UR2).Copy Destination:=Range("N2")
ActiveSheet.ShowAllData
Columns("IV").ClearContents
Range("N2").Select
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
CheckArea = "N20:N150" '<<< Adattare
If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then Exit Sub
Application.EnableEvents = False
Call NomiUnivoci
Application.EnableEvents = True
End Sub
Che cosa ti da errore di vba? Quale e' il codice completo? Quale errore e dove? Quali testate devi cancellare?ma se cancello tutte le righe della testata mi da errore di vba.
=SE(VAL.ERRORE(INDICE($N$20:$N$50;PICCOLO(SE(VAL.NUMERO(CONFRONTA(RIF.RIGA($A$20:$A$50)-19;CONFRONTA($N$20:$N$50;$N$20:$N$50;0);0));CONFRONTA($N$20:$N$50;$N$20:$N$50;0);"");RIF.RIGA(A1))));"";INDICE($N$20:$N$50;PICCOLO(SE(VAL.NUMERO(CONFRONTA(RIF.RIGA($A$20:$A$50)-19;CONFRONTA($N$20:$N$50;$N$20:$N$50;0);0));CONFRONTA($N$20:$N$50;$N$20:$N$50;0);"");RIF.RIGA(A1))))
CANAPONE ha scritto:Ciao,
torno alle formule.
Potresti provare la matriciale da confermare con control+maiusc+invio per estrarre -nell'esempio- un elenco univoco da N20:N50.
- Codice: Seleziona tutto
=SE(VAL.ERRORE(INDICE($N$20:$N$50;PICCOLO(SE(VAL.NUMERO(CONFRONTA(RIF.RIGA($A$20:$A$50)-19;CONFRONTA($N$20:$N$50;$N$20:$N$50;0);0));CONFRONTA($N$20:$N$50;$N$20:$N$50;0);"");RIF.RIGA(A1))));"";INDICE($N$20:$N$50;PICCOLO(SE(VAL.NUMERO(CONFRONTA(RIF.RIGA($A$20:$A$50)-19;CONFRONTA($N$20:$N$50;$N$20:$N$50;0);0));CONFRONTA($N$20:$N$50;$N$20:$N$50;0);"");RIF.RIGA(A1))))
Anch'io uso Excel 2003 e sono costretto a raddoppiare la lunghezza della formula non potendo usare SE.ERRORE.
Saluti
Sub NomiUnivoci_new()
For x = 0 To 29
benef(x) = ""
Next x
' trovo la prima riga del corpo (la cerco per evitare che se qualcuno
' inserisce o elimina righe nella testata ...)
PR = 0
For xben = 1 To 500
If Trim(Cells(xben, 10).Value) = "Beneficiario finale" Then
PR = xben + 1
Exit For
End If
Next xben
' trovata l'intestazione con PR > 0 ora leggo le righe del corpo
If PR > 0 Then
UR = Range("J" & Rows.Count).End(xlUp).Row
For y = PR To UR
' nella cella c'e' un valore
If Len(Trim(Cells(y, 10).Value)) <> 0 Then
testben = ""
testben = Trim(Cells(y, 10).Value)
' trovo l'ultimo elemento inserito nell'array
For yy = 0 To 29
If Len(Trim(benef(yy))) = 0 Then
ultimo = yy
Exit For
End If
Next yy
' cerco il nome nell'array
trov = 0
For y1 = 0 To 29
If benef(y1) = testben Then trov = 1
Next y1
If trov = 0 Then
If ultimo = 0 Then
benef(ultimo) = testben
Else
benef(ultimo) = testben
End If
End If
End If
Next y
' ora cancello le celle riepilogative e poi riscrivo l'array
For be = 9 To PR - 2
Cells(be, 10).Value = ""
Next be
For be = 0 To ultimo
If Len(Trim(benef(be))) <> 0 Then
Cells(be + 9, 10).Value = benef(be)
End If
Next be
End If
End Sub
=INDICE(indiretto("$N$20:$N$50");PICCOLO(SE(VAL.NUMERO(CONFRONTA(RIF.RIGA(indiretto("$A$20:$A$50"))-19;CONFRONTA(indiretto("$N$20:$N$50";indiretto("$N$20:$N$50");0);0));CONFRONTA(indiretto("$N$20:$N$50");indiretto("$N$20:$N$50");0);"");c2)))
Flash30005 ha scritto:Potrai richiamarla con il codice postato da Anthony, ad ogni variazione del range N20:N150
es.:
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
CheckArea = "N20:N150" '<<< Adattare
If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then Exit Sub
Application.EnableEvents = False
Call NomiUnivoci
Application.EnableEvents = True
End Sub
ciao
Private Sub Worksheet_Change(ByVal Target As Range)
' -----------------------------------------------------------------
' B E N E F I C I A R I
'------------------------------------------------------------------
PR = 0
For xben = 1 To 500
If Trim(Cells(xben, 15).Value) = "Beneficiario finale" Then
PR = xben + 1
Exit For
End If
Next xben
' -----------------------------------------------------------------
' C O N T A N T E
'------------------------------------------------------------------
PRe = 0
For xben = 1 To 500
If Trim(Cells(xben, 13).Value) = "Tagli" Then
PRe = xben + 1
Exit For
End If
Next xben
' *************** AREA BENEFICIARI **************
CheckArea = ("O" & PR & ":O500") '<<< Adattare
If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then
Exit Sub
else
Call NomiUnivoci_new
endif
' *************** AREA TAGLI **************
CheckArea2 = ("M" & PRe & ":M500") '<<< Adattare
If Application.Intersect(Target, Range(CheckArea2)) Is Nothing Then
Exit Sub
else
Call totale_tagli
endif
End Sub
'...
CheckArea = ("O" & PR & ":O500") '<<< Adattare
If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then
GoTo SaltaO '<<<< modificare così
Else
' Call NomiUnivoci_new
End If
SaltaO: '<<<< aggiungere etichetta
' *************** AREA TAGLI **************
CheckArea2 = ("M" & PRe & ":M500") '<<< Adattare
'...
Flash30005 ha scritto:Perché quando viene soddisfatta la prima condizione la macro exce dalla routine con Exit Sub
pertanto devi mettere una etichetta e un Goto
- Codice: Seleziona tutto
'...
CheckArea = ("O" & PR & ":O500") '<<< Adattare
If Application.Intersect(Target, Range(CheckArea)) Is Nothing Then
GoTo SaltaO '<<<< modificare così
Else
' Call NomiUnivoci_new
End If
SaltaO: '<<<< aggiungere etichetta
' *************** AREA TAGLI **************
CheckArea2 = ("M" & PRe & ":M500") '<<< Adattare
'...
Ciao
Torna a Applicazioni Office Windows
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Aggiornare cella con somma quando aggiungo nuova colonna Autore: marcopont |
Forum: Applicazioni Office Windows Risposte: 1 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
confrontare e evidenziare 2 fogli excel Autore: niccia |
Forum: Applicazioni Office Windows Risposte: 7 |
Visitano il forum: Nessuno e 19 ospiti