Forum » Programiranje » [excel]duplikati
[excel]duplikati
baksuz ::
jaz imam manjsi problem imam en primitiven makro za brisanje duplikatov, sedaj bi ga pa rad sfriziral. v cem je problem. imam zelo veliko tabelo z imeni in naslovi. toda ena oseba ima vec naslovov, in en naslov je bolj pomemeben k drug.za dolocen seznam pa rabim samo en naslov ene osebe. torej kako bi se dalo prirediti moj makro tako, da bi najprej poiskal duplikat potem pa zbrisal tistega,ki bi bil npr. imel v stolpcu A oznako 2 in pustil tistega z oznako 1. z ciframi bi jaz oznacil pomembnost, ce pa ima kdo drugo idejo pa prosim. moj makro je, ki pa sedaj zbrise vse duplikate in ne mores locevati po pomembnosti :
Sub TestForDups()
Dim LLoop As Integer
Dim LTestLoop As Integer
Dim Lrows As Integer
Dim LRange As String
Dim LCnt As Integer
'Column values
Dim LColA_1, LColB_1, LColC_1 As String
Dim LColA_2, LColB_2, LColC_2 As String
'Test first 2000 rows in spreadsheet for duplicates (delete any duplicates found)
Lrows = 2000
LLoop = 2
LCnt = 0
'Check first 2000 rows in spreadsheet
While LLoop < = Lrows
LColA_1 = "A" & CStr(LLoop)
LColB_1 = "B" & CStr(LLoop)
LColC_1 = "C" & CStr(LLoop)
If Len(Range(LColA_1).Value) > 0 Then
'Test each value for uniqueness
LTestLoop = LLoop + 1
While LTestLoop < = Lrows
If LLoop < > LTestLoop Then
LColA_2 = "A" & CStr(LTestLoop)
LColB_2 = "B" & CStr(LTestLoop)
LColC_2 = "C" & CStr(LTestLoop)
'Value has been duplicated in another cell (based on values in columns A to H)
If (Range(LColA_1).Value = Range(LColA_2).Value) _
And (Range(LColB_1).Value = Range(LColB_2).Value) _
And (Range(LColC_1).Value = Range(LColC_2).Value) Then
'Delete the duplicate
Rows(CStr(LTestLoop) & ":" & CStr(LTestLoop)).Select
Selection.Delete Shift:=xlUp
'Decrement counter since row was deleted
LTestLoop = LTestLoop - 1
LCnt = LCnt + 1
End If
End If
LTestLoop = LTestLoop + 1
Wend
End If
LLoop = LLoop + 1
Wend
'Reposition back on cell A1
Range("A1").Select
MsgBox CStr(LCnt) & " rows have been deleted."
End Sub
Sub TestForDups()
Dim LLoop As Integer
Dim LTestLoop As Integer
Dim Lrows As Integer
Dim LRange As String
Dim LCnt As Integer
'Column values
Dim LColA_1, LColB_1, LColC_1 As String
Dim LColA_2, LColB_2, LColC_2 As String
'Test first 2000 rows in spreadsheet for duplicates (delete any duplicates found)
Lrows = 2000
LLoop = 2
LCnt = 0
'Check first 2000 rows in spreadsheet
While LLoop < = Lrows
LColA_1 = "A" & CStr(LLoop)
LColB_1 = "B" & CStr(LLoop)
LColC_1 = "C" & CStr(LLoop)
If Len(Range(LColA_1).Value) > 0 Then
'Test each value for uniqueness
LTestLoop = LLoop + 1
While LTestLoop < = Lrows
If LLoop < > LTestLoop Then
LColA_2 = "A" & CStr(LTestLoop)
LColB_2 = "B" & CStr(LTestLoop)
LColC_2 = "C" & CStr(LTestLoop)
'Value has been duplicated in another cell (based on values in columns A to H)
If (Range(LColA_1).Value = Range(LColA_2).Value) _
And (Range(LColB_1).Value = Range(LColB_2).Value) _
And (Range(LColC_1).Value = Range(LColC_2).Value) Then
'Delete the duplicate
Rows(CStr(LTestLoop) & ":" & CStr(LTestLoop)).Select
Selection.Delete Shift:=xlUp
'Decrement counter since row was deleted
LTestLoop = LTestLoop - 1
LCnt = LCnt + 1
End If
End If
LTestLoop = LTestLoop + 1
Wend
End If
LLoop = LLoop + 1
Wend
'Reposition back on cell A1
Range("A1").Select
MsgBox CStr(LCnt) & " rows have been deleted."
End Sub
darkolord ::
Tole
spremeniš v
'Delete the duplicate Rows(CStr(LTestLoop) & ":" & CStr(LTestLoop)).Select Selection.Delete Shift:=xlUp 'Decrement counter since row was deleted LTestLoop = LTestLoop - 1 LCnt = LCnt + 1
spremeniš v
If Range(LColA_2).Value = "2" Then 'Delete the duplicate Rows(CStr(LTestLoop) & ":" & CStr(LTestLoop)).Select Selection.Delete Shift:=xlUp 'Decrement counter since row was deleted LTestLoop = LTestLoop - 1 LCnt = LCnt + 1 End If
baksuz ::
hvala,zadeva skoraj pravilno deluje, zdej imam samo se eno zeljo, a bi se delo tudi to dvojko zbrisat. torej da bi na koncu ostal samo en zapis in to ta z oznako 1. vse dvojke bi se pa zbrisale.
smetko ::
če hočeš da ti izbriše vse razen 1 potem spremeni
If Range(LColA_2).Value = "2" Then
spremeniš v
If Range(LColA_2).Value <> "1" Then
If Range(LColA_2).Value = "2" Then
spremeniš v
If Range(LColA_2).Value <> "1" Then
No comment
darkolord ::
A lahko daš en primer, kako tabelca trenutno izgleda, kako izgleda ko zalaufaš makro in kako naj bi pravilno izgledala?
baksuz ::
evo primer kako tabela kao izgleda, in kako bi mogla izgledat
prvotna tabela
1 mirko st 1
2 mirko st 2
2 mirko re 3
1 mirko et 4
1 er er 5
1 mirko re 6
1 mirko we 7
1 mirko tz 8
2 mirko we 9
2 mirko st 10
2 mirko st 11
to naredi makro
1 mirko st 1
2 mirko st 2
2 mirko re 3
1 mirko et 4
1 er er 5
1 mirko re 6
1 mirko we 7
1 mirko tz 8
2 mirko we 9
tako pa naj bi zgledalo
1 mirko st 1
1 mirko et 4
1 er er 5
1 mirko re 6
1 mirko we 7
1 mirko tz 8
prvotna tabela
1 mirko st 1
2 mirko st 2
2 mirko re 3
1 mirko et 4
1 er er 5
1 mirko re 6
1 mirko we 7
1 mirko tz 8
2 mirko we 9
2 mirko st 10
2 mirko st 11
to naredi makro
1 mirko st 1
2 mirko st 2
2 mirko re 3
1 mirko et 4
1 er er 5
1 mirko re 6
1 mirko we 7
1 mirko tz 8
2 mirko we 9
tako pa naj bi zgledalo
1 mirko st 1
1 mirko et 4
1 er er 5
1 mirko re 6
1 mirko we 7
1 mirko tz 8
darkolord ::
Hm, kaj pa nekako takole... Sodeč po vzorcu je iskanje duplikatov nepotrebno, če izbrišeš vse vrstice, ki imajo "2" v prvem stolpcu:
Sub TestForDups() Dim LLoop As Integer Dim Lrows As Integer 'Column values Dim LColA_1, LColB_1, LColC_1 As String 'Test first 2000 rows in spreadsheet for duplicates (delete any duplicates found) Lrows = 2000 LLoop = 2 LCnt = 0 'Check first 2000 rows in spreadsheet While LLoop <= Lrows LColA_1 = "A" & CStr(LLoop) LColB_1 = "B" & CStr(LLoop) LColC_1 = "C" & CStr(LLoop) If Len(Range(LColA_1).Value) > 0 Then If Range(LColA_1).Value = "2" Then Rows(CStr(LLoop) & ":" & CStr(LLoop)).Select Selection.Delete Shift:=xlUp LLoop = LLoop - 1 End If End If LLoop = LLoop + 1 Wend 'Reposition back on cell A1 Range("A1").Select End Sub
Zgodovina sprememb…
- spremenilo: darkolord ()
baksuz ::
sem probu pa ne dela.
samo bistvo je da išče tud duplikate saj so imena in primeki podvojeni. te cifre so pa zato da se ve ker nslov je bolj pomemben.in tist k ma stevilko je bolj pomemben zato moramo na ta naslov poslat posto.
lp
samo bistvo je da išče tud duplikate saj so imena in primeki podvojeni. te cifre so pa zato da se ve ker nslov je bolj pomemben.in tist k ma stevilko je bolj pomemben zato moramo na ta naslov poslat posto.
lp
Vredno ogleda ...
Tema | Ogledi | Zadnje sporočilo | |
---|---|---|---|
Tema | Ogledi | Zadnje sporočilo | |
» | vba arrayOddelek: Programiranje | 920 (613) | Vazelin |
» | Naloga v ExceluOddelek: Pomoč in nasveti | 797 (645) | Isotropic |
» | Excel: izbris obeh podvojenih vrednostiOddelek: Programiranje | 1093 (1037) | dvojka |
» | [VBA]ExcelOddelek: Programiranje | 1133 (1091) | mmaestro |
» | [Excel] problem z makrojem, visual basic (strani: 1 2 )Oddelek: Programiranje | 5649 (5112) | steev |