Thema Datum  Von Nutzer Rating
Antwort
Rot Hilfe beim umschreiben eines Quellcodes VBA Excel
 11.07.2007 12:14:47 Christine
Solved

Ansicht des Beitrags:
Von:
Christine		 Datum:
11.07.2007 12:14:47		 Views:
1969		 Rating:
     
Antwort:
 Nein
Thema:
Hilfe beim umschreiben eines Quellcodes VBA Excel
Hallo,

ich habe ein kleines Problem und es wäre super wenn mir da jemand von euch helfen könnte da ich in VBA nicht sehr bewandert bin.
Ich habe eine riesige Excel Datenbank mit Duplikaten(und ganz wenigen nicht-Duplikaten) und ein VBA Script das mir hilft diese zu löschen. Funktioniert auch super...
ABER ich muss auch die dazugehörigen originale löschen. Soll heissen:
Jedes Original das ein Duplikat hat->Original löschen und Duplikat.

Kann mir jemand helfen wo ich das script umschreiben muss oder ist das zu viel arbeit? Wäre einfach nur sehr praktisch für mich...

Greetz
Christine


Sub DoppelteEintraegeLoeschen()

Dim colUnique As New Collection
Dim lngAbZeile As Long
Dim lngArr As Long
Dim lngC As Long
Dim lngCalc As Long
Dim lngDup As Long
Dim lngMaxArrays As Long
Dim lngZ As Long
Dim lngZeile As Long
Dim lngZeilenArray As Long
Dim lngZeilenBereich As Long
Dim rngArea As Range
Dim rngAuswahl As Range
Dim rngC As Range
Dim rngDel() As Range
Dim rngSel As Range
Dim strSuchbereich As String
Dim strZeile As String
Dim varAuswahl() As Variant
Dim varC As Variant
Set rngSel = Selection.EntireColumn
lngZeilenBereich = ActiveSheet.UsedRange.Rows.Count
On Error GoTo FehlerBehandlung
lngCalc = Application.Calculation
Set rngAuswahl = Application.Intersect(Selection.EntireColumn, ActiveSheet.UsedRange)
strSuchbereich = rngAuswahl.Address(0, 0)
lngAbZeile = Abs(CLng(Application.InputBox( _
vbLf & "Ab welcher Zeile soll geprüft werden?", "Prüfbereich festlegen", 2, , , , , 1)))
If lngAbZeile > 0 And lngAbZeile 1 Then
For lngZ = 2 To lngArr
Set rngDel(0) = Application.Union(rngDel(0), rngDel(lngZ))
Next lngZ
End If
lngDup = rngDel(0).Cells.Count / 256
Application.Intersect(rngSel, rngDel(0)).Select
Application.ScreenUpdating = True
If MsgBox("Es wurden " & lngDup & " Duplikate im Bereich" & vbLf & _
strSuchbereich & vbLf & _
"gefunden." & vbLf & vbLf & "Sollen sie jetzt gelöscht werden?", _
vbQuestion Or vbYesNo Or vbDefaultButton2) = vbYes Then
Application.ScreenUpdating = False
For lngZ = lngArr To 1 Step -1
rngDel(lngZ).Delete
Next lngZ
rngSel.Select
Application.ScreenUpdating = True
End If

FehlerBehandlung:
Select Case Err.Number
Case 457
If rngDel(lngArr) Is Nothing Then
Set rngDel(lngArr) = Rows(lngZeile + lngAbZeile - 1)
Else
Set rngDel(lngArr) = Application.Union(rngDel(lngArr), Rows(lngZeile + lngAbZeile - 1))
End If
If rngDel(lngArr).Areas.Count = lngMaxArrays Then
lngArr = lngArr + 1
ReDim Preserve rngDel(lngArr)
End If
Resume Next
Case 13, 91
MsgBox "Im Bereich" & vbLf & vbLf & """" & strSuchbereich & """" & vbLf & vbLf & "gibt es keine Duplikate."
Case Is > 0
MsgBox "Fehlernummer: " & Err.Number & vbLf & vbLf & _
"Felerbeschreibung: " & Err.Description

End Select
Application.Calculation = lngCalc
End Sub




Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Hilfe beim umschreiben eines Quellcodes VBA Excel
 11.07.2007 12:14:47 Christine
Solved