13. januar 2007 - 10:57Der er
9 kommentarer og 1 løsning
dubletter - identificering - flytning af data - sletning
Jeg har et regne ark med ca. 10.000 rækker - dataområde a1:m10000. I kolonne a er et unikt identifikation i form af et nr. dubletterne ligger i kolonne a - her optræder nogle 1-4 gange - med forskellig data på række i området b:m Jeg har behov for en makro der finder 1. dublet. tager informationen i kolonne m og flytter den op i rækken ovenover og placere data her i kolonne N. Går tilbage til dubletten i rækken nedenfor og sletter hele rækken. Finder dublet nr.2, tager informationen i kolonne m og flytter den op i rækken ovenover men denne gang placeres data i kolonne O. og sletter hele rækken. Ditto med dublet 3. hvor data blot placeres i kolonne P. og sletter hele rækken.
Således at resultatet bliver at listen kun indeholder unikke nr. i kolonne a, men at data fra dubletterne i kolonne M er placeres i kolonnerne N O P Håber nogen har et godt bud. MVH HHB
Dim r, t, t2, t3, rw, nr, tValue() t3 = Cells(65500, 1).End(xlUp).Row ReDim tValue(t3) For rw = 1 To Cells(65500, 1).End(xlUp).Row tValue(rw) = Cells(rw, 1) & Cells(rw, 2) & _ Cells(rw, 5) & Cells(rw, 6) & Cells(rw, 7) & Cells(rw, 8) & Cells(rw, 9) Next For t = 1 To UBound(tValue) If tValue(t) <> "" Then For t2 = t + 1 To UBound(tValue) If tValue(t) = tValue(t2) Then tValue(t2) = "" End If Next End If Next For t = 1 To UBound(tValue) If tValue(t) = "" Then nr = nr + 1: Cells(t, 1) = "" Cells(t - 1, 13 + nr) = Cells(t, 13) End If Next Range("A1:A10000").Select Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Cells(1, 1).Select
Dim r, t, t2, t3, rw, nr, tValue() t3 = Cells(65500, 1).End(xlUp).Row ReDim tValue(t3) For rw = 1 To Cells(65500, 1).End(xlUp).Row tValue(rw) = Cells(rw, 1) Next For t = 1 To UBound(tValue) If tValue(t) <> "" Then For t2 = t + 1 To UBound(tValue) If tValue(t) = tValue(t2) Then tValue(t2) = "" End If Next End If Next For t = 1 To UBound(tValue) If tValue(t) = "" Then nr = nr + 1: Cells(t, 1) = "" Cells(t - 1, 13 + nr) = Cells(t, 13) End If Next Range("A1:A10000").Select Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Cells(1, 1).Select
Public Sub SamleDubletter() Dim A1 As Variant, A2 As Variant, ID As Long Dim I As Long, Y As Long, X As Integer, RW As Long RW = Cells(65500, 1).End(xlUp).Row A1 = Range("A1:A" & RW) A2 = Range("A1:Q" & RW) For I = 1 To RW X = 0 If IsNumeric(A1(I, 1)) And A1(I, 1) <> Empty Then ID = A1(I, 1) X = 1 For Y = I + 1 To RW If A1(Y, 1) = ID Then A2(I, 13 + X) = A2(Y, 13) A2(Y, 1) = Empty A1(Y, 1) = Empty X = X + 1 End If Next End If Next Range("A1:Q" & RW) = A2 Range("A1:A" & RW).Select Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Cells(1, 1).Select End Sub
Kære Execelent tak for dit bud. Desværre gå den i runtime error 1004. KÆre Bak Tak for dit bud. det virker. hvordan vil makroen virke om der er eks. 8 antal dubletter ja faktisk et uendelig MVH
kunne tyde på der er/var flere end 255 dubletter defor ryger den ud over kanten (der er jo kun 256 kolonner) så prøv denne.
Sub xSletDubletter()
Dim r, t, t2, t3, rw, nr, tValue() t3 = Cells(65500, 1).End(xlUp).Row ReDim tValue(t3) For rw = 1 To Cells(65500, 1).End(xlUp).Row tValue(rw) = Cells(rw, 1) & Cells(rw, 2) & _ Cells(rw, 5) & Cells(rw, 6) & Cells(rw, 7) & Cells(rw, 8) & Cells(rw, 9) Next For t = 1 To UBound(tValue) If tValue(t) <> "" Then For t2 = t + 1 To UBound(tValue) If tValue(t) = tValue(t2) Then tValue(t2) = "" End If Next End If Next For t = 1 To UBound(tValue) If tValue(t) = "" Then nr = nr + 1: Cells(t, 1) = "" If nr > 240 Then nr = 1 Cells(t - 1, 13 + nr) = Cells(t, 13) End If Next Range("A1:A10000").Select Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Cells(1, 1).Select
Uendeligt, kan det jo ikke være, men 242 kan der være. Public Sub SamleDubletter() Dim A1 As Variant, A2 As Variant, ID As Long Dim I As Long, Y As Long, X As Integer, RW As Long RW = Cells(65500, 1).End(xlUp).Row A1 = Range("A1:A" & RW) A2 = Range("A1:IV" & RW) ' Nu er der plade til 242 dubletter For I = 1 To RW X = 0 If IsNumeric(A1(I, 1)) And A1(I, 1) <> Empty Then ID = A1(I, 1) X = 1 For Y = I + 1 To RW If A1(Y, 1) = ID Then A2(I, 13 + X) = A2(Y, 13) A2(Y, 1) = Empty A1(Y, 1) = Empty X = X + 1 End If Next End If Next Range("A1:Q" & RW) = A2 Range("A1:A" & RW).Select Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Cells(1, 1).Select End Sub
Public Sub SamleDubletter() Dim A1 As Variant, A2 As Variant, ID As Long Dim I As Long, Y As Long, X As Integer, RW As Long RW = Cells(65500, 1).End(xlUp).Row A1 = Range("A1:A" & RW) A2 = Range("A1:IV" & RW) ' Nu er der plade til 242 dubletter For I = 1 To RW X = 0 If IsNumeric(A1(I, 1)) And A1(I, 1) <> Empty Then ID = A1(I, 1) X = 1 For Y = I + 1 To RW If A1(Y, 1) = ID Then A2(I, 13 + X) = A2(Y, 13) A2(Y, 1) = Empty A1(Y, 1) = Empty X = X + 1 End If Next End If Next Range("A1:IV" & RW) = A2 Range("A1:A" & RW).Select Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Cells(1, 1).Select End Sub
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
