Moderatori: Anthony47, Flash30005
Sub Bah()
Dim myD As Object, mIt As Object, myK
Dim J As Long, I As Long, myNext As Long
'
Columns("A:A").Insert Shift:=xlToRight
Columns("A:A").ColumnWidth = 35
Set myD = CreateObject("Scripting.Dictionary")
For J = 2 To Cells(2, Columns.Count).End(xlToLeft).Column
myD.RemoveAll
For I = 2 To Cells(Rows.Count, J).End(xlUp).Row
myK = Cells(I, J)
If Not myD.Exists(myK) Then
myD.Add (myK), 1
Else
myD.Item(myK) = myD.Item(myK) + 1
End If
Next I
myNext = Cells(Rows.Count, "A").End(xlUp).Row + 2
For I = 0 To myD.Count - 1
If myD.items()(I) > 1 Then
Cells(myNext, "A").Resize(myD.items()(I), 1) = myD.keys()(I)
myNext = myNext + myD.items()(I)
End If
Next I
Next J
MsgBox ("Boh...")
End Sub
For J = 2 To 2
Sub Bah2()
Dim cList As String, dList As String, I As Long, myNext As Long
Dim LastR As Long, iCount As Long
'
cList = "B" '<<< La colonna con la lista iniziale
dList = "A" '<<< La colonna in cui verranno scritti i doppioni
'
myNext = 2
Range(Cells(myNext, dList), Cells(myNext, dList).End(xlDown)).ClearContents
LastR = Cells(Rows.Count, cList).End(xlUp).Row
For I = 2 To LastR
iCount = Application.WorksheetFunction.CountIf(Cells(2, cList).Resize(LastR, 1), Cells(I, cList).Value)
If iCount > 1 And Application.WorksheetFunction.CountIf(Cells(1, dList).Resize(myNext, 1), Cells(I, cList).Value) = 0 Then
Cells(myNext, dList).Resize(iCount, 1).Value = Cells(I, cList).Value
myNext = myNext + iCount
End If
Next
MsgBox ("Completato...")
End Sub
Come noterai, non seleziono niente; confronto usando Conta.Se, e non copio/incollo ma mi limito a scrivere il valoreLe cose importanti che cerco di capire nel ciclo sono:
selezionare, confrontare e incollare il dato
Sub Macchec()
Dim myD As Object, mIt As Object, myK
Dim J As Long, I As Long, myNext As Long
Dim mySplit, IJ As Long, K As Long
'
Columns("A:A").Insert Shift:=xlToRight
Columns("A:A").ColumnWidth = 35
Set myD = CreateObject("Scripting.Dictionary")
For J = 2 To Cells(2, Columns.Count).End(xlToLeft).Column
myD.RemoveAll
For I = 2 To Cells(Rows.Count, J).End(xlUp).Row
myK = Mid(Cells(I, J), 2 + InStr(1, Cells(I, J), "- ", vbTextCompare))
mySplit = Split(myK, " ", , vbTextCompare)
myK = mySplit(0)
If Not myD.Exists(myK) Then
myD.Add (myK), I
Else
myD.Item(myK) = myD.Item(myK) & "-" & I
End If
Next I
IJ = 0
For I = 0 To myD.Count - 1
K = 0
myNext = Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print myD.items()(I)
mySplit = Split(myD.items()(I), "-", , vbTextCompare)
If UBound(mySplit) > 0 Then
IJ = IJ + 1
For K = 0 To UBound(mySplit)
Cells(myNext + K, "A") = Cells(CLng(mySplit(K)), J).Value
Next K
End If
Next I
If IJ > 0 Then
Cells(myNext + K, "A") = " "
End If
Next J
MsgBox ("Boh...")
End Sub
Torna a Applicazioni Office Windows
File batch per copiare file selezionato da menu contestuale Autore: valle1975 |
Forum: Programmazione Risposte: 3 |
Aggiungere macro verifica doppioni Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 10 ospiti