Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

Quelltexterklärung?

Frage Microsoft Microsoft Office

Mitglied: Kleina

Kleina (Level 1) - Jetzt verbinden

04.02.2011, aktualisiert 12:15 Uhr, 2614 Aufrufe, 2 Kommentare

Hallo zusammen.

Habe einen Quellcode bekommen. Dieser ist ein Makro, um doppelte Datensätze einer Tabelle zu entfernen.
Das es funktioniert habe ich schon getestet.

Nur bin ich in VB nicht grad ein talent.

könnte mir jemand dieses Quellcode erklären??

Danke schonmal im Voraus !!!

01.
Sub DoppelteEintraegeLoeschen() 
02.
   
03.
  Dim colUnique As New Collection 
04.
  Dim lngAbZeile As Long 
05.
  Dim lngArr As Long 
06.
  Dim lngC As Long 
07.
  Dim lngCalc As Long 
08.
  Dim lngDup As Long 
09.
  Dim lngMaxArrays As Long 
10.
  Dim lngZ As Long 
11.
  Dim lngZeile As Long 
12.
  Dim lngZeilenArray As Long 
13.
  Dim lngZeilenBereich As Long 
14.
  Dim rngArea As Range 
15.
  Dim rngAuswahl As Range 
16.
  Dim rngC As Range 
17.
  Dim rngDel() As Range 
18.
  Dim rngSel As Range 
19.
  Dim strSuchbereich As String 
20.
  Dim strZeile As String 
21.
  Dim varAuswahl() As Variant 
22.
  Dim varC As Variant 
23.
  Set rngSel = Selection.EntireColumn 
24.
  lngZeilenBereich = ActiveSheet.UsedRange.Rows.Count 
25.
On Error GoTo FehlerBehandlung 
26.
  lngCalc = Application.Calculation 
27.
  Set rngAuswahl = Application.Intersect(Selection.EntireColumn, ActiveSheet.UsedRange) 
28.
  strSuchbereich = rngAuswahl.Address(0, 0) 
29.
  lngAbZeile = Abs(CLng(Application.InputBox( _ 
30.
    vbLf & "Ab welcher Zeile soll geprüft werden?", "Prüfbereich festlegen", 2, , , , , 1))) 
31.
  If lngAbZeile > 0 And lngAbZeile <= lngZeilenBereich Then 
32.
    Set rngAuswahl = Application.Intersect(Rows(lngAbZeile & ":" & lngZeilenBereich), rngSel) 
33.
  Else 
34.
    MsgBox "Die Zeile " & lngAbZeile & " liegt außerhalb des Bereichs """ & strSuchbereich & """!" 
35.
    Exit Sub 
36.
  End If 
37.
  lngZeilenArray = lngZeilenBereich - lngAbZeile + 1 
38.
  rngAuswahl.Select 
39.
  lngArr = 1 
40.
  ReDim rngDel(lngArr) 
41.
  lngMaxArrays = lngZeilenBereich / 50 
42.
  strSuchbereich = rngAuswahl.Address(0, 0) 
43.
  Application.Calculation = xlCalculationManual 
44.
  Application.ScreenUpdating = False 
45.
  For Each rngArea In rngAuswahl.Areas 
46.
    For Each rngC In rngArea.Columns 
47.
      lngC = lngC + 1 
48.
      ReDim Preserve varAuswahl(1 To lngC) 
49.
      varAuswahl(lngC) = rngC.Value 
50.
    Next rngC 
51.
  Next rngArea 
52.
  colUnique.Add 0, "" 'wenn 1. Leerzeile auch berücksichtigt werden soll 
53.
  For lngZeile = 1 To lngZeilenArray 
54.
    strZeile = "" 
55.
    For lngZ = 1 To lngC 
56.
      strZeile = strZeile & CStr(varAuswahl(lngZ)(lngZeile, 1)) 
57.
    Next lngZ 
58.
    colUnique.Add lngZeile, strZeile 
59.
  Next lngZeile 
60.
  Set rngDel(0) = rngDel(1) 
61.
  lngArr = lngArr + (rngDel(lngArr) Is Nothing) 
62.
  If lngArr > 1 Then 
63.
    For lngZ = 2 To lngArr 
64.
      Set rngDel(0) = Application.Union(rngDel(0), rngDel(lngZ)) 
65.
    Next lngZ 
66.
  End If 
67.
  lngDup = rngDel(0).Cells.Count / 256 
68.
  Application.Intersect(rngSel, rngDel(0)).Select 
69.
  Application.ScreenUpdating = True 
70.
  If MsgBox("Es wurden " & lngDup & " Duplikate im Bereich" & vbLf & _ 
71.
            strSuchbereich & vbLf & _ 
72.
            "gefunden." & vbLf & vbLf & "Sollen sie jetzt gelöscht werden?", _ 
73.
            vbQuestion Or vbYesNo Or vbDefaultButton2) = vbYes Then 
74.
    Application.ScreenUpdating = False 
75.
    For lngZ = lngArr To 1 Step -1 
76.
        rngDel(lngZ).Delete 
77.
    Next lngZ 
78.
    rngSel.Select 
79.
    Application.ScreenUpdating = True 
80.
  End If 
81.
FehlerBehandlung: 
82.
  Select Case Err.Number 
83.
    Case 457 
84.
      If rngDel(lngArr) Is Nothing Then 
85.
        Set rngDel(lngArr) = Rows(lngZeile + lngAbZeile - 1) 
86.
      Else 
87.
        Set rngDel(lngArr) = Application.Union(rngDel(lngArr), Rows(lngZeile + lngAbZeile - 1)) 
88.
      End If 
89.
      If rngDel(lngArr).Areas.Count = lngMaxArrays Then 
90.
        lngArr = lngArr + 1 
91.
        ReDim Preserve rngDel(lngArr) 
92.
      End If 
93.
      Resume Next 
94.
    Case 13, 91 
95.
        MsgBox "Im Bereich" & vbLf & vbLf & """" & strSuchbereich & """" & vbLf & vbLf & "gibt es keine Duplikate." 
96.
    Case Is > 0 
97.
      MsgBox "Fehlernummer: " & Err.Number & vbLf & vbLf & _ 
98.
            "Felerbeschreibung: " & Err.Description 
99.
      'für Entwicklung zum Testen 
100.
'      Application.Calculation = lngCalc 
101.
'      On Error GoTo 0 
102.
'      Resume 
103.
  End Select 
104.
  Application.Calculation = lngCalc 
105.
End Sub
Mitglied: Skyemugen
04.02.2011 um 12:11 Uhr
Aloha,

im Groben und Ganzen oder Zeile für Zeile? wobei man sich hier sogar vieles ergoogeln kann ... und mit 'nem Bisschen Englisch-Kenntnis auch verstehen

greetz André
Bitte warten ..
Mitglied: Kleina
04.02.2011 um 12:21 Uhr
im Groben würde reichen..es gibt ja nur manche Sachen die ich dabei nicht verstehe.
Die deklaration der variabeln ist ja klar.
Die Msgbox versteht sich auch von selbst.

nur bei der Abfrage habe ich meine Probleme
Bitte warten ..
Neuester Wissensbeitrag
Windows 10

Powershell 5 BSOD

(8)

Tipp von agowa338 zum Thema Windows 10 ...

Heiß diskutierte Inhalte
Microsoft
Ordner mit LW-Buchstaben versehen und benennen (21)

Frage von Xaero1982 zum Thema Microsoft ...

Netzwerkmanagement
gelöst Anregungen, kleiner Betrieb, IT-Umgebung (18)

Frage von Unwichtig zum Thema Netzwerkmanagement ...

Windows Update
Treiberinstallation durch Windows Update läßt sich nicht verhindern (17)

Frage von liquidbase zum Thema Windows Update ...