Moderatori: Anthony47, Flash30005
Sub ikVuote()
Dim eCell As Range, LastR As Long, myMatch, hLight As Long
Dim I As Long, J As Long, staRow As Long, staCol As Long, mErr As Long
Dim ME2 As String, ME3 As String
'
On Error Resume Next
LastR = Range("B:F").Find(What:="*", After:=Range("B1"), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
On Error GoTo 0
'
staCol = 39 '39=AM
staRow = 3
hLight = RGB(255, 255, 0)
For Each aa In Range("B5:F" & LastR)
If aa.Interior.Color = hLight Then aa.ClearContents: aa.Interior.Color = xlNone
Next aa
Cells(staRow, staCol).Resize(1000, 1).Interior.Color = xlNone
For I = 5 To LastR
For J = 2 To 6
myMatch = CVErr(2200)
If Cells(I, J) = "" Then
reGet:
myMatch = Application.Match(Cells(staRow, staCol), Cells(I, "B").Resize(1, 5), False)
If IsError(myMatch) Then
Cells(I, J) = Cells(staRow, staCol)
Cells(I, J).Interior.Color = hLight
Cells(staRow, staCol).Interior.Color = hLight
staRow = staRow + 1
Else
staRow = staRow + 1
End If
If Cells(staRow, staCol) = "" Then Exit For
If Not IsError(myMatch) Then GoTo reGet
Else
If Cells(I, J).Interior.Color = hLight Then Cells(I, J).Interior.Color = xlNone
End If
Next J
If Cells(staRow, staCol) = "" Then Exit For
If Not IsError(myMatch) Then mErr = mErr + 1
Next I
If mErr > 0 Then ME2 = vbCrLf & "Righe incompilate: " & mErr Else ME2 = ""
If Cells(staRow, staCol) = "" Then ME3 = vbCrLf & "Rimpiazzi terminati su riga " & I Else ME3 = ""
MsgBox ("Completato" & ME2 & ME3)
End Sub
Ho mandato in esecuzione la tua macro e ho notato che rimangono dei numeri in colonna AM ossia i numeri 11,16,75 e 76 questi numeri sono idonei alle cinquine di riga 47, il numero 11 e 16, così si completa la cinquina e ancora il 76 per completare la cinquina della riga 48 mentre il numero 75 trova posto, senza completare la cinquina, in riga 50 e precisamente in B50
Questa non la capiro' mai, ma so che non e' fondamentale per il mio contributoAggiungo; le cinquine complete servono per le ripetizioni delle quaterne che è il cuore di tutto questo lavoro mente le cinquine non completate serviranno per la taratura della matrice che genera le cinquine e, i numeri rimasti in colonna AM, servono per la taratura dei numeri scelti
Sub ikVuote2()
Dim myMatch, hLight As Long, fCell As Range, dDbug As Boolean
Dim I As Long, J As Long, staRow As Long, staCol As Long, mErr As Long
Dim ME2 As String, ME3 As String
Dim LookArea, K As Long, MArea As Range, WWI As Long
'
LookArea = Array("B5:F22", "B24:F41", "B43:F60") '<<< Gli intervalli da esaminare
'
staCol = 39 '<<< 39=AM
staRow = 3 '<<< riga 3
hLight = RGB(255, 255, 3) 'solo per debug
dDbug = False '
'
For K = 0 To UBound(LookArea)
Set MArea = Range(LookArea(K))
For I = MArea.Cells(1, 1).Row To (MArea.Cells(1, 1).Row + MArea.Rows.Count - 1)
WWI = staRow
For J = MArea.Cells(1, 1).Column To (MArea.Cells(1, 1).Column + MArea.Columns.Count - 1)
myMatch = CVErr(2200)
If Cells(I, J) = "" Then
reGet:
myMatch = Application.Match(Cells(WWI, staCol), Cells(I, "B").Resize(1, 5), False)
If IsError(myMatch) Then
Cells(I, J) = Cells(WWI, staCol)
If dDbug Then Cells(I, J).Interior.Color = hLight
Cells(WWI, staCol).Delete Shift:=xlUp
Else
WWI = WWI + 1
End If
If Cells(WWI, staCol) = "" Then Exit For
If Not IsError(myMatch) Then GoTo reGet
End If
Next J
If Cells(staRow, staCol) = "" Then Exit For
If Not IsError(myMatch) Then
mErr = mErr + 1
End If
Next I
If Cells(staRow, staCol) = "" Then Exit For
Next K
'
If mErr > 0 Then ME2 = vbCrLf & "Match errors: " & mErr Else ME2 = ""
If Cells(staRow, staCol) = "" Then ME3 = vbCrLf & "Rimpiazzi esauriti su riga " & I Else ME3 = ""
MsgBox ("Completato" & ME2 & ME3)
End Sub
Sub ikVuote3()
Dim myMatch, hLight As Long, fCell As Range, dDbug As Boolean
Dim I As Long, J As Long, staRow As Long, staCol As Long, mErr As Long
Dim ME2 As String, ME3 As String, ME4 As String, Resid As Long
Dim LookArea, K As Long, MArea As Range, WWI As Long
'
LookArea = Array("B5:F22", "B24:F41", "B43:F60") '<<< Gli intervalli da esaminare
'
staCol = 39 '<<< 39=AM
staRow = 3 '<<< riga 3
hLight = RGB(255, 255, 3) 'solo per debug
dDbug = False '
'
For K = 0 To UBound(LookArea)
Set MArea = Range(LookArea(K))
For I = MArea.Cells(1, 1).Row To (MArea.Cells(1, 1).Row + MArea.Rows.Count - 1)
WWI = staRow
For J = MArea.Cells(1, 1).Column To (MArea.Cells(1, 1).Column + MArea.Columns.Count - 1)
myMatch = CVErr(2200)
If Cells(I, J) = "" Then
reGet:
myMatch = Application.Match(Cells(WWI, staCol), Cells(I, "B").Resize(1, 5), False)
If IsError(myMatch) Then
Cells(I, J) = Cells(WWI, staCol)
If dDbug Then Cells(I, J).Interior.Color = hLight
Cells(WWI, staCol).Delete Shift:=xlUp
Else
WWI = WWI + 1
End If
' If Cells(WWI, staCol) = "" And J < 7 Then Exit For
If Cells(I, J) = "" And IsError(myMatch) Then Exit For
If Not IsError(myMatch) Then GoTo reGet
End If
Next J
If Cells(staRow, staCol) = "" And J < 7 Then Exit For
If Not IsError(myMatch) Or (Cells(WWI, staCol) = "" And J < 7) Then
mErr = mErr + 1: Debug.Print I, J
End If
Next I
If Cells(staRow, staCol) = "" Then Exit For
Next K
'
If mErr > 0 Then ME2 = vbCrLf & "Match errors: " & mErr Else ME2 = ""
Resid = Application.WorksheetFunction.CountA(Cells(staRow, staCol).Resize(100, 1))
If Resid > 0 Then ME4 = vbCrLf & "Valori residui: " & Resid Else ME4 = ""
If Cells(staRow, staCol) = "" And J < 7 Then
ME3 = vbCrLf & "Rimpiazzi esauriti su riga " & I
Else
ME3 = ""
End If
MsgBox ("Completato" & ME2 & ME3 & ME4)
End Sub
Torna a Applicazioni Office Windows
Inserimento parziale valore cella in MessageBox Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 6 |
Mettere tutto MAIUSCOLO un range di celle Autore: raimea |
Forum: Applicazioni Office Windows Risposte: 7 |
Aggiornare cella con somma quando aggiungo nuova colonna Autore: marcopont |
Forum: Applicazioni Office Windows Risposte: 1 |
Aumenta altezza riga in base valore cella Autore: trittico69 |
Forum: Applicazioni Office Windows Risposte: 47 |
Importare immagini a seconda del testo in una cella Autore: Paolo67met |
Forum: Applicazioni Office Windows Risposte: 4 |
Visitano il forum: Nessuno e 7 ospiti