Arrays ohne Doppler zusammenfassen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Norbert,
vom Prinzip her so.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Sub TextArray()
Dim strFile As String
Dim tmp() As Variant, arrTxt() As Variant, l As Long
Dim strTmp As String
Dim WerteListe
Dim SCRDIC

strFile = "F:\test.txt" 'Textdatei - anpassen!

arrTxt = Range("A1:A15") 'heir dein Code für das zweite Array - anpassen!

Set SCRDIC = CreateObject("Scripting.dictionary")

Open strFile For Input As #1

Do While Not EOF(1)

    Input #1, strTmp

    On Error Resume Next
    SCRDIC.Add strTmp, 0
    On Error GoTo 0

Loop

Close #1

For l = 0 To UBound(arrTxt)
    On Error Resume Next
    SCRDIC.Add arrTxt(l, 1), 0
    On Error GoTo 0
Next

tmp = SCRDIC.keys
QuickSort tmp

Open strFile For Output As #1

For l = 0 To UBound(tmp)
    strTmp = tmp(l)
    Print #1, strTmp
Next

Close #1

Set SCRDIC = Nothing
End Sub

Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant

UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)

P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)

Do

    Do While (data(P1) < T1)
        P1 = P1 + 1
    Loop

    Do While (data(P2) > T1)
        P2 = P2 - 1
    Loop

    If P1 <= P2 Then
        T2 = data(P1)
        data(P1) = data(P2)
        data(P2) = T2
        P1 = P1 + 1
        P2 = P2 - 1
    End If

Loop Until (P1 > P2)

If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG

End Sub

Gruß Sepp

Hallo Norbert
Dann sieht der Code bestimmt so ähnlich aus.
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...) Option Explicit Public Sub test() Dim MyDic Dim Bereich As Range Dim FSO Dim Datei Dim Spl Dim Ausgabe Dim L As Long Dim Zelle As Range Set MyDic = CreateObject("Scripting.Dictionary") Set FSO = CreateObject("Scripting.Filesystemobject") Set Bereich = Sheets("Tabelle1").Range("A1:D20") 'anpassen Set Datei = FSO.opentextfile("C:/Neu Textdokument.txt") 'anpassen 'Textdatei einlesen Spl = Split(Datei.readall, vbCrLf) For L = 0 To UBound(Spl) - 1 MyDic(Spl(L)) = MyDic(Spl(L)) Next 'Zellen einlesen For Each Zelle In Bereich If Zelle.Font.ColorIndex = 3 Then MyDic(Zelle.Value) = MyDic(Zelle.Value) Next Ausgabe = QuickSort(MyDic.keys) End Sub Public Function QuickSort(vSort As Variant, _ Optional ByVal lngStart As Variant, _ Optional ByVal lngEnd As Variant) If IsMissing(lngStart) Then lngStart = LBound(vSort) If IsMissing(lngEnd) Then lngEnd = UBound(vSort) Dim i As Long Dim J As Long Dim h As Variant Dim X As Variant i = lngStart: J = lngEnd X = vSort((lngStart + lngEnd) / 2) Do While (vSort(i) X): J = J - 1: Wend If (i J) If (lngStart
Die sortierten Unikate befinden sich im Array "Ausgabe".
das musst du in die Textdatei zurückschreiben.
ransi

Beliebteste Forumthreads (12 Monate)

	A	B	C
1	LM1AZ	TQWR6	3ADU0
2	PNSX2	Q6PQN	KB12J
3	8CUXZ	VE6WE	A5CYF
4	BX8L1	47PK6	598XK
5	F1ERZ	W2UE6	599SO
6	20CE4	BQ79L	5D6W5
7	6B0VP	T2IL6	DU7FS
8	T4HQJ	JI6OJ	47GLN
9	UEI24	N71IF	BACDR
10	J2VKD	2JVTP	KI7D7
11	9P83P	23F0H	RN5SF

	E
1	03G
2	0J4
3	286
4	316
5	42U
6	47PK6
7	485
8	598XK
9	599SO
10	5D6W5
11	6XR
12	7ZV
13	871
14	988
15	9B4
16	B1V
17	BJS
18	BQ79L
19	C12
20	CFB
21	CW4
22	DU7FS
23	E7U
24	EPU
25	GOU
26	HFV
27	JEI
28	KZ9
29	O48
30	QXA
31	RXI
32	SGV
33	SW5
34	T2IL6
35	U0P
36	UA7
37	W2UE6
38	Z14

Arrays ohne Doppler zusammenfassen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Arrays ohne Doppler zusammenfassen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread