Großes Problem

Hallo Excel-Experten,
ich habe ein großes Problem und hoffe auf Unterstützung von Euch.
Ich habe eine Tabelle mit folgenden Aufbau:
Zeile 1 = Überschrift
ab Zeile 2 kommen dann Kundendaten
In Spalte A befindet sich zu jedem Kunden die Kundennummer. In den Spalten G bis N werden weitere Kundennummer diesen Kunden aufgeführt. Diese Kundenummern können sich wiederholen, auch mit der Kundennummer aus Spalte A identisch sein. Leere Zellen sind auch möglich.
Meine Aufgabe ist nun, die Kundennummern in den Spalten G bis N zu sortieren und dabei zu berücksichtigen, dass keine Kundennummer doppelt vorkommt. Es darf auch nicht die Kundennummer aus Spalte A dort auftauchen.
Das ganz soll mittels eines Makros gelöst werden, weil das Blatt ca. 4000 Zeilen hat.
Wer kann mir helfen? Ich habe leider keinen Ansatz. :-(
Vielen vielen Dank!
Liebe Grüße
Claudia

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub test() Dim myArray(8) As String Dim help As String Dim change As Boolean Dim j As Long Dim i As Long Dim n As Long For i = 1 To 4000 For j = 1 To 8 If ActiveSheet.Cells(i, j + 6).Value ActiveSheet.Cells(i, 1).Value Then myArray(j) = ActiveSheet.Cells(i, j + 6).Value Else myArray(j) = "" End If ActiveSheet.Cells(i, j + 6).Clear Next j change = True While change change = False n = 1 While n

Sub löschen() 'aber vorher erst sortieren Dim loletzte as long Dim lngCounter as long Dim lngCounter2 as long dim lngcounter3 as long loletzte= cells(rows.count,1).end(xlup).row for lngCounter = loletzte to 2 step -1 for lngcounter2=7 to 14 if cells(lngcounter,lngcounter2)=cells(lngcounter,1) then rows(lngcounter).delete exit for end if next for lngcounter2=7 to 14 for lngcounter3=7 to 14 if cells(lngcounter,lngcounter2)=cells(lngcounter-1,longcounter3) then rows(lngcounter).delete exit for end if next next for lngcounter2 = 7 to 14 for lngcounter3 = 7 to 14 if cells(lngcounter, lngcounter2)= cells(lngcounter, lngcounter3) then rows(lngcounter).delete exit for end if next End Sub

Hi Claudia,
probier das mal aus:


Option Explicit
Sub test2()
Dim zz As Long, varA, arrW, lngS As Long, cc As Long, jj As Long, lngZ, arrE
For zz = 2 To Cells(Rows.Count, 1).End(xlUp).Row
varA = Cells(zz, 1)
arrW = Application.Transpose(Application.Transpose(Cells(zz, 7).Resize(, 7)))
lngS = UBound(arrW)
For cc = 1 To lngS
If arrW(cc) = varA Or arrW(cc) = 0 Or IsEmpty(arrW(cc)) Then
arrW(cc) = "x"
Else
For jj = cc + 1 To lngS
If arrW(jj) = arrW(cc) Then
arrW(cc) = "x"
Exit For
End If
Next jj
End If
Next cc
Quicksort arrW, 1, lngS
lngZ = WorksheetFunction.Count(arrW)
If lngZ > 0 Then
ReDim arrE(1 To lngZ)
For cc = 1 To lngZ
arrE(cc) = arrW(cc)
Next cc
If lngZ > 0 Then Cells(zz, 7).Resize(, lngZ) = (arrE)
End If
If lngZ

Arbeitet das Makro so richtig? (übrigens nach deiner Mappe nur bis Spalte M, nicht N)
Gebraucht wird dabei ein Quicksort. Den habe ich in einem eigenen Modul untergebracht:


Option Explicit
' {Boris} am 31.08.2008 14:38:33
' www.herber.de/forum/archiv/1004to1008/t1006193.htm#1006201
Function Quicksort(arrW, lngL As Long, lngR As Long)
Dim Teiler As Long
If lngR > lngL Then
Teiler = Teile(arrW, lngL, lngR)
Call Quicksort(arrW, lngL, Teiler - 1)
Call Quicksort(arrW, Teiler + 1, lngR)
End If
End Function
Private Function Teile(arrW, lngL As Long, lngR As Long)
Dim lngInd As Long, ii As Long
lngInd = lngL
For ii = lngL To lngR - 1
If arrW(ii)

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Sub KD_Nummern_Bereinigen() Application.ScreenUpdating = False Dim ze As Long Range("X1").Value = "KD-Nr" For ze = 2 To Cells(Rows.Count, 1).End(xlUp).Row If WorksheetFunction.CountA(Cells(ze, "G").Resize(, 7)) > 0 Then Cells(ze, "A").Copy Destination:=Range("X2") Cells(ze, "G").Resize(, 7).Copy Cells(3, "X").PasteSpecial xlPasteValues, Transpose:=True Columns("X").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Z1"), Unique:= _ True Range("Z3").Resize(7, 1).Sort Key1:=Range("Z3"), header:=xlNo Range("Z3").Resize(7, 1).Copy Cells(ze, "G").PasteSpecial xlPasteValues, Transpose:=True End If Next Range("X:Z").clear Application.ScreenUpdating = True End Sub

Sub test() Dim myArray(8) As String Dim help As String Dim change As Boolean Dim j As Long Dim i As Long Dim n As Long For i = 2 To 4000 For j = 1 To 7 If ActiveSheet.Cells(i, j + 6).Value ActiveSheet.Cells(i, 1).Value Then myArray(j) = ActiveSheet.Cells(i, j + 6).Value Else myArray(j) = "" End If ActiveSheet.Cells(i, j + 6).ClearContents Next j change = True While change change = False n = 1 While n

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread