Moderatori: Anthony47, Flash30005
=SOMMA(--(VAL.NUMERO(CONFRONTA(SE($A$1:$A$34=H1;B1:B34);($A$1:$A$34=H2)*$B$1:$B$34;0))))
Public Function CountEqualDigit(var1 As Variant, var2 As Variant) As Long
' conta le cifre di var1 che sono presenti in var2
Dim L1 As Long, L2 As Long, S1 As String, S2 As String, c1 As Long, c2 As Long, digit1 As Byte, digit2 As Byte
CountEqualDigit = -1 '(valore di errore; restituito in caso di parametri errati o vuoti
If IsNumeric(var1) And IsNumeric(var2) Then
S1 = Trim(CStr(var1))
S2 = Trim(CStr(var2))
L1 = Len(S1)
L2 = Len(S2)
If L1 > 0 And L2 > 0 Then
CountEqualDigit = 0
For c1 = 1 To L1
digit1 = Val(Mid(S1, c1, 1))
For c2 = 1 To L2
digit2 = Val(Mid(S2, c2, 1))
If digit1 = digit2 Then
CountEqualDigit = CountEqualDigit + 1
Exit For
End If
Next c2
Next c1
End If
End If
End Function
=SE($A$1:$A$34=H1;B1:B34)
($A$1:$A$34=H2)*$B$1:$B$34
CANAPONE ha scritto:Ciao,
il segmento
- Codice: Seleziona tutto
=SE($A$1:$A$34=H1;B1:B34)
seleziona i numeri corrispondenti ad H1
CONFRONTA cerca questi numeri nella matrice di numeri prodotta nel secondo argomento
- Codice: Seleziona tutto
($A$1:$A$34=H2)*$B$1:$B$34
che produce 34 numeri; tanti zero più i numeri corrispondendi ad H2.
Se CONFRONTA trova i primi numeri -prodotti da SE($A$1:$A$34=H1;B1:B34)- fra questo secondo gruppo di numeri, restituisce la posizione: un numero, non mi interessa quale.
Se non li trova restituisce messaggio d'errore.
VAL.NUMERO che contiene tutta la formula restituisce VERO, se CONFRONTA ha restituito la posizione (è un numero, quindi VERO)
FALSO se non trova nulla (il messaggio d'errore n/d produce FALSO).
Con il -- davanti VERO diventa 1, FALSO divento zero.
SOMMA addiziona questi 1.
=SOMMA(--(VAL.NUMERO(CONFRONTA(RIF.RIGA(1:100000);CONFRONTA(SE($A$1:$A$34=H1;B1:B34);($A$1:$A$34=H2)*$B$1:$B$34;0);0))))
CANAPONE ha scritto:Ciao,
Se questa casistica non esiste nel caso che stai gestendo ( per esempio due o più 8690 in corrispondenza di due o più 1BA01), la formula potrebbe andare.
Saluti
CANAPONE ha scritto:Ciao, porterei le serie di due codici da confrontare (H1 E H2) uno accanto all'altro (H1 ed I1): in H1:I50 -esempio scrivi tutte le coppie di codici e la stessa formula
=SOMMA(--(VAL.NUMERO(CONFRONTA(SE($A$1:$A$34=H1;B1:B34);($A$1:$A$34=I1)*$B$1:$B$34;0))))
Poi usi un semplice MAX , o un INDICE(..CONFRONTA(MAX... sui risultati che ottieni dalle formule matrice.
Forse si può fare tutto con una formula: no saprei dirti come, sicuramente perderesti parecchia sensibilità sui numeri da controllare.
Sempre che abbia capito
Sub pappr()
Dim VArr1, I As Long, LastA As Long, Dest As String, V As Long, H As Long, rDim As Long
Dim RArr(), cPos As Variant, cRig As Long, myComm As Long
'
Dest = "K2" '<<< L' area ove sara' creata la tabella esiti
'
LastA = Cells(Rows.Count, 1).End(xlUp).Row
VArr1 = Range("A2:B" & LastA).Value
'
Range(Dest).Resize(100, 100).ClearContents ' AZZERA Area di creazione risultati
Range("A1:A" & LastA).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
Dest), Unique:=True
rDim = Range(Dest, Range(Dest).End(xlDown)).Count - 1
Range(Dest).Offset(1, 0).Resize(rDim, 1).Copy
Range(Dest).Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
r3d1 = Application.WorksheetFunction.Min(Range("B2:B" & LastA).Value)
r3d2 = Application.WorksheetFunction.Max(Range("B2:B" & LastA).Value)
ReDim RArr(1 To rDim, r3d1 To r3d2)
'riposiziona:
For I = LBound(VArr1, 1) To UBound(VArr1, 1)
cPos = Application.Match(VArr1(I, 1), Range(Dest).Offset(0, 1).Resize(1, rDim), 0)
RArr(cPos, VArr1(I, 2)) = 1
Next I
'Calcola:
For V = 1 To rDim - 1
For H = V + 1 To rDim
myComm = 0
For I = LBound(RArr, 2) To UBound(RArr, 2)
If RArr(V, I) <> "" Then
If RArr(H, I) = RArr(V, I) Then
myComm = myComm + 1
End If
End If
Next I
Range(Dest).Offset(V, H).Value = myComm
Next H
Next V
End Sub
Anthony47 ha scritto:Non sono in grado di fare un collaudo spinto, per carenza di file esemplificativo, ma direi che questa macro potrebbe produrre i confronti richiesti (in sostituzione delle formule):
- Codice: Seleziona tutto
Sub pappr()
Dim VArr1, I As Long, LastA As Long, Dest As String, V As Long, H As Long, rDim As Long
Dim RArr(), cPos As Variant, cRig As Long, myComm As Long
'
Dest = "K2" '<<< L' area ove sara' creata la tabella esiti
'
LastA = Cells(Rows.Count, 1).End(xlUp).Row
VArr1 = Range("A2:B" & LastA).Value
'
Range(Dest).Resize(100, 100).ClearContents ' AZZERA Area di creazione risultati
Range("A1:A" & LastA).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
Dest), Unique:=True
rDim = Range(Dest, Range(Dest).End(xlDown)).Count - 1
Range(Dest).Offset(1, 0).Resize(rDim, 1).Copy
Range(Dest).Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
r3d1 = Application.WorksheetFunction.Min(Range("B2:B" & LastA).Value)
r3d2 = Application.WorksheetFunction.Max(Range("B2:B" & LastA).Value)
ReDim RArr(1 To rDim, r3d1 To r3d2)
'riposiziona:
For I = LBound(VArr1, 1) To UBound(VArr1, 1)
cPos = Application.Match(VArr1(I, 1), Range(Dest).Offset(0, 1).Resize(1, rDim), 0)
RArr(cPos, VArr1(I, 2)) = 1
Next I
'Calcola:
For V = 1 To rDim - 1
For H = V + 1 To rDim
myComm = 0
For I = LBound(RArr, 2) To UBound(RArr, 2)
If RArr(V, I) <> "" Then
If RArr(H, I) = RArr(V, I) Then
myComm = myComm + 1
End If
End If
Next I
Range(Dest).Offset(V, H).Value = myComm
Next H
Next V
End Sub
Inseriscila in un modulo standard (es Modulo1), personalizza l' istruzione marcata <<< poi mandala in esecuzione.
La macro assume che il codice sia in colonna A e il numero in colonna B; verra' creata una tabella all' indirizzo specificato (K2, nel mio codice), con in verticale e in orizzontale i vari Codici, e all' incrocio il "numero di numeri" in comune.
Attenzione: non sapendo quanto sara' grande la tabella di destinazione la macro AZZERA un' area di 100 righe * 100 Colonne a partire dall' indirizzo specificato (K2 nel mio codice); tienilo in conto quando decidi dove creare la tabella degli esiti.
Ciao, fai sapere.
Torna a Applicazioni Office Windows
Disattivazione funzione " Telemetria " in W 10 Autore: mastino46 |
Forum: Software Windows Risposte: 5 |
Barra Applicazioni tasto destro non attivo e ALTRO Autore: ricky53 |
Forum: Sistemi Operativi Windows Risposte: 6 |
Scelta da elenco a discesa che ne apre un altro Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 12 |
Visitano il forum: Nessuno e 18 ospiti