Moderatori: Anthony47, Flash30005
Sub MatchBlocks()
Dim Bk1 As Range, Bk2 As Range, oRow As Range
Dim kList(), iList(), oMatch()
Dim cKey As String, I As Long, J As Long, cMat As Long
'
Sheets("Riscontro").Select
Set Bk1 = Application.InputBox("Inizio Blocco 1?", , , , , , , 8)
Set Bk2 = Application.InputBox("Inizio Blocco 2?", , , , , , , 8)
'
Set Bk1 = Range(Bk1.Cells(1, 1), Bk1.Cells(1, 1).End(xlDown).Offset(0, 5))
Set Bk2 = Range(Bk2.Cells(1, 1), Bk2.Cells(1, 1).End(xlDown).Offset(0, 5))
ReDim oMatch(1 To Bk1.Rows.Count, 1 To 1)
ReDim kList(1 To Bk2.Rows.Count)
ReDim iList(1 To Bk2.Rows.Count)
'Crea keys
For I = 1 To Bk2.Rows.Count
Set oRow = Bk2.Cells(I, 1).Resize(1, 6)
For J = 1 To 6
kList(I) = kList(I) & Format(Application.WorksheetFunction.Small(oRow, J), "00-")
Next J
Next I
'Scan Block 1
For I = 1 To Bk1.Rows.Count
Set oRow = Bk1.Cells(I, 1).Resize(1, 6)
cKey = ""
For J = 1 To 6
cKey = cKey & Format(Application.WorksheetFunction.Small(oRow, J), "00-")
Next J
'Controlla se esiste:
mymatch = Application.Match(cKey, kList, False)
If Not IsError(mymatch) Then
oMatch(I, 1) = Bk2.Cells(mymatch, 1).Address(0, 0)
cMat = cMat + 1
End If
Next I
'Scrive risultati:
Bk1.Offset(0, 6).Resize(UBound(oMatch), 1).Value = oMatch
Application.WorksheetFunction.Count (oMatch)
MsgBox (cMat & " Match")
End Sub
'Controlla se esiste:
For J = 1 To UBound(kList)
mymatch = Application.Match(cKey, kList, False)
If Not IsError(mymatch) Then
oMatch(I, 1) = oMatch(I, 1) & Bk2.Cells(mymatch, 1).Address(0, 0) & " "
kList(mymatch) = "zzz"
cMat = cMat + 1
Else
Exit For
End If
Next J
Next I
'Scrive risultati:
Torna a Applicazioni Office Windows
Input box range di celle di destinazione variabile Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 17 |
Aggiungere macro verifica doppioni Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Ricky0185 e 12 ospiti