| | Post: 97 | Registrato il: 03/10/2015
| Città: ALBAREDO PER SAN MARCO | Età: 44 | Utente Junior | 2003 | | OFFLINE |
|
  05/04/2018 20:25 | |
Buona sera da Matteo.Allego il file chiamato fascia.Mi servirebbe una macro che mi conta nel foglio (contatore-Finale) il numero di combinazione trovate nelle cinque fasce trovate riportando il risultato nella colonna E da me creato per esempio.Ovviamente dopo i numeri saranno cambiati in tutte le 5 fascie.Grazie anticipatamente Matteo |
|
| | Post: 2.787 | Registrato il: 03/04/2013
| Utente Veteran | Excel 2000 - 2013 | | OFFLINE | |
|
| 06/04/2018 07:10 | |
Buona giornata, Matteo;
sono consapevole che è una soluzione piuttosto contorta ma, in attesa di una soluzione più professionale, potresti provare con questo Codice VBA:
Option Explicit
Option Base 1
Sub Analizza()
Application.ScreenUpdating = False
Dim NRc As Long, NCl As Long, NRX As Long
Dim x As Byte, y As Byte, w As Byte, z As Byte
Dim Qtr As String
Dim Cmb() As String
Dim Frq() As Byte
With Worksheets("fascia")
Sheets("contatore-finale").Select
NRc = Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(1, 5), Cells(50, 5)).ClearContents
ReDim Cmb(NRc)
ReDim Frq(NRc)
For x = 1 To NRc
For y = 1 To 4
NCl = Cells(x, Columns.Count).End(xlToLeft).Column
If Cells(x, y).Value = "" Then Exit For
Cmb(x) = Cmb(x) & Cells(x, y).Value & "-"
Next y
Cmb(x) = Left(Cmb(x), Len(Cmb(x)) - 1)
Next x
For x = 1 To 21 Step 5 ' Colonne
NRX = .Cells(Rows.Count, x).End(xlUp).Row
For y = 2 To NRX ' Righe
Qtr = ""
For w = 0 To 3
If .Cells(y, x + w).Value <> "" Then Qtr = Qtr & .Cells(y, x + w).Value & "-"
Next w
If Qtr <> "" Then Qtr = Left(Qtr, Len(Qtr) - 1)
For z = 1 To NRc
If Qtr = Cmb(z) Then
Frq(z) = Frq(z) + 1
Cells(z, 5) = Frq(z)
End If
Next z
Next y
Next x
End With
Application.ScreenUpdating = True
Cells(1, 5).Select
End Sub
Non ho eseguito test approfonditi ma dalle poche prove che ho condotto mi sembra funzionare.
Buon Lavoro.
Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 97 | Registrato il: 03/10/2015
| Città: ALBAREDO PER SAN MARCO | Età: 44 | Utente Junior | 2003 | | OFFLINE |
|
| 06/04/2018 18:56 | |
Buon sera da Matteo. Ringrazio Giuseppe Mn per la macro è perfetta. Ma devo però sempre inserire io nel foglio contatore-finale i numeri da ricercare . Allego due foto per fare un esempio. C'è un metodo che mi porta in automatico nella riga 5 del foglio contatore 17 79 90 33 ecc. ecc. ecc.? Saluti da Gatto di Marmo ![[SM=x423051]](http://www.erismag.it/Servizio/ForumExcel/Smiles/Faccina_0031.gif) |
| | Post: 2.793 | Registrato il: 03/04/2013
| Utente Veteran | Excel 2000 - 2013 | | OFFLINE | |
|
| 06/04/2018 20:57 | |
Buona sera, Matteo; in realtà nelle Colonne A, B, C e D del Foglio di lavoro "contatore-finale" ho riportato "a manina" in sequenza tutte le combinazioni presenti in tutte le 5 Fasce poi, utilizzando la Funzione "Rimuovi duplicati" ho ottento l'elenco delle combinazioni univoche. Ovviamente si può pensare ad un Codice VBA per evitare l'operazione manuale, ma in questo momento non riesco ad aiutarti. Se non ricevi risposte adeguate, potrei scrivere il Codice VBA ma non prima di Mercoledì p.v. A disposizione. Buona serata e buon fine settimana. Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 2.796 | Registrato il: 03/04/2013
| Utente Veteran | Excel 2000 - 2013 | | OFFLINE | |
|
| 07/04/2018 08:16 | |
Buona giornata, Matteo;
sono riuscito a ritagliarmi qualche minuti per modificare il Codice VBA.
In realtà ho dovuto scrivere il Codice VBA "Rimuovi" che andrà salvato in un Modulo dedicato; non chiedermi il perchè ma sembra sia l'unico modo per farlo funzionare.
Option Explicit
Sub Rimuovi()
ActiveSheet.Range(Cells(1, 1), Cells(NRc, 4)).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo
End Sub
Il Codice VBA "Analizza" va salvato in altro Modulo e modificato in questo modo:
Option Explicit
Option Base 1
Public NRc As Long
Sub Analizza()
Application.ScreenUpdating = False
Dim NCl As Long, NRX As Long
Dim x As Integer
Dim y As Byte, w As Byte, z As Byte
Dim Qtr As String
Dim Cmb() As String
Dim Frq() As Byte
Sheets("contatore-finale").Select
NRc = Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(1, 1), Cells(NRc, 4)).ClearContents
Range(Cells(1, 5), Cells(NRc, 5)).ClearContents
NRc = Range("J" & Rows.Count).End(xlUp).Row
Range(Cells(1, 10), Cells(NRc, 13)).Clear
Columns("A:E").Interior.Pattern = xlNone
With Worksheets("fascia")
NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
NRX = .Range("A" & Rows.Count).End(xlUp).Row
Range(.Cells(2, 1), .Cells(NRX, 4)).Copy Cells(NRc, 10)
NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
NRX = .Range("F" & Rows.Count).End(xlUp).Row
Range(.Cells(2, 6), .Cells(NRX, 9)).Copy Cells(NRc, 10)
NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
NRX = .Range("K" & Rows.Count).End(xlUp).Row
Range(.Cells(2, 11), .Cells(NRX, 14)).Copy Cells(NRc, 10)
NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
NRX = .Range("P" & Rows.Count).End(xlUp).Row
Range(.Cells(2, 16), .Cells(NRX, 19)).Copy Cells(NRc, 10)
NRc = Range("J" & Rows.Count).End(xlUp).Row + 1
NRX = .Range("U" & Rows.Count).End(xlUp).Row
Range(.Cells(2, 21), .Cells(NRX, 24)).Copy Cells(NRc, 10)
NRc = Range("J" & Rows.Count).End(xlUp).Row
For x = NRc To 1 Step -1
If Cells(x, 10).Value = "" Then Cells(x, 10).EntireRow.Delete
Next x
NRc = Range("J" & Rows.Count).End(xlUp).Row
Range(Cells(1, 10), Cells(NRc, 13)).Copy Cells(1, 1)
Range(Cells(1, 10), Cells(NRc, 13)).Clear
Call Rimuovi
NRc = Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(1, 5), Cells(50, 5)).ClearContents
ReDim Cmb(NRc)
ReDim Frq(NRc)
For x = 1 To NRc
For y = 1 To 4
NCl = Cells(x, Columns.Count).End(xlToLeft).Column
If Cells(x, y).Value = "" Then Exit For
Cmb(x) = Cmb(x) & Cells(x, y).Value & "-"
Next y
Cmb(x) = Left(Cmb(x), Len(Cmb(x)) - 1)
Next x
For x = 1 To 21 Step 5 ' Colonne
NRX = .Cells(Rows.Count, x).End(xlUp).Row
For y = 2 To NRX ' Righe
Qtr = ""
For w = 0 To 3
If .Cells(y, x + w).Value <> "" Then Qtr = Qtr & .Cells(y, x + w).Value & "-"
Next w
If Qtr <> "" Then Qtr = Left(Qtr, Len(Qtr) - 1)
For z = 1 To NRc
If Qtr = Cmb(z) Then
Frq(z) = Frq(z) + 1
Cells(z, 5) = Frq(z)
End If
Next z
Next y
Next x
End With
Application.ScreenUpdating = True
Cells(1, 5).Select
End Sub
Nel Foglio di lavoro "contatore-finale" crei un pulsante legato al Codice VBA "Analizza".
Buon fine settimana.
Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 189 | Registrato il: 03/10/2015
| Città: ALBAREDO PER SAN MARCO | Età: 44 | Utente Junior | 2003 | | OFFLINE |
|
| 16/03/2020 14:35 | |
Buona giorno Forum ,buon giorno GiuseppeMn,
il contatore è perfetto si potrebbe però
estendere la macro con una colonna in più per ogni lista. Intendo aggiungere range AE per prima Lista ,Range GK per seconda lista ,range MQ per terza lista ,range SW per quarta lista ,range YAC per quinta lista .Associo file con nuova struttura ,bisognerebbe però cambiare il codice.Il risultato nel foglio contatore-finale lo scritto io manualmente per farvi capire il criterio se eseguite la macro analizza adesso il risultato verrà ovviamente sbagliato. Grazie Matteo |
|
|
|
|