10. maj 2006 - 12:57Der er
16 kommentarer og 1 løsning
slet dubletter
Hej
jeg mangler en makro der kan slette dubletter i en XL ark
jeg fandt denne i et andet spg. men den er for langsom og der er heller ikke grund til at markere rækkerne med rødt først
Public Sub MakerDubletterRøde() col = ActiveCell.Column Rowcount = Cells(65536, col).End(xlUp).Row Range(Cells(1, col), Cells(65536, col).End(xlUp)).Select For I = 1 To Rowcount If Cells(I, col).Interior.ColorIndex <> 3 Or Cells(I, col) <> "" Then For I1 = I + 1 To Rowcount If Cells(I, col) = Cells(I1, col) Then Cells(I1, col).Interior.ColorIndex = 3 End If Next End If Next End Sub
denne køres efter at du har tjekket om det er ok, så slettes de. Public Sub FjernDubletterRøde() col = ActiveCell.Column Rowcount = Cells(65536, col).End(xlUp).Row Range(Cells(1, col), Cells(65536, col).End(xlUp)).Select For I = 1 To Rowcount If Cells(I, col).Interior.ColorIndex = 3 Then Cells(I, col).EntireRow.Delete Shift:=xlUp I = I - 1 Rowcount = Rowcount - 1 End If Next End Sub
De fleste virksomheder har efterhånden bevist, at AI virker.
Pilotprojekter leverer resultater. Medarbejdere bruger generative AI-værktøjer. Nye use cases dukker op på tværs af organisationen.
Sub sletDub() Dim rRange As Range Dim DummyRange As Range Dim Cell As Range Set rRange = Range("A1:A500") For Each Cell In rRange.Cells Set DummyRange = Range(rRange(1, 1), Cell) If Application.CountIf(DummyRange, Cell.Value) > 1 Then If DeleteRange Is Nothing Then
Set DeleteRange = Cell Else Set DeleteRange = Union(DeleteRange, Cell) End If End If Next Cell DeleteRange.EntireRow.Delete Set rRange = Nothing Set DeleteRange = Nothing Set DummyRange = Nothing Set Cell = Nothing End Sub
Set AllCells = Selection On Error Resume Next For Each cell In AllCells Uniqs.Add cell.Value, CStr(cell.Value) If Err.Number <> 0 Then cell = "" Err.Clear Next cell
Sorry, den havde den fejl at hvis der ikke var nogen dubletter slettede den alt.. Dette er korrigeret her
Sub RemoveDuplicates1() Dim AllCells As Range, cell As Range Dim Uniqs As New Collection Dim oldCalc As Long Dim Dup As Boolean Application.ScreenUpdating = False oldCalc = Application.Calculation Application.Calculation = xlCalculationManual
Set AllCells = Selection On Error Resume Next For Each cell In AllCells Uniqs.Add cell.Value, CStr(cell.Value) If Err.Number <> 0 Then cell = "" Dup = True Err.Clear End If Next cell
If Dup = True Then AllCells.SpecialCells(xlCellTypeBlanks).Select Selection.EntireRow.Delete Shift:=xlUp End If Application.ScreenUpdating = True Application.Calculation = oldCalc Set Uniqs = Nothing 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.
