Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
176to180
176to180
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Suchen und in nächste Spalte schreiben

Suchen und in nächste Spalte schreiben
01.11.2002 17:31:26
Werner
Ich habe folgendes für mich unlösbares Problem. In Spalte A habe ich verschiedene Zahlen (ca 10000)und in Spalte B Bezeichnungen.

1 a
1
1 b
2
3 c
3 h
3 j
4 k

jetz möchte ich das in einer Zeile in n Spalten haben

1 a b
2
3 c h j
4 k

wer kann mir helfen

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Suchen und in nächste Spalte schreiben
01.11.2002 18:13:09
Ramses
Hallo Werner,

probier mal folgendes:

Sub Find_All_Characters()
Dim Cr As Long, CC As Integer, CC2 As Integer
Dim Nr As Long, NC As Integer
Dim Tstr As String, wks As String
Dim Qe As String, Header As Integer
CC = 1 'Spalte A
CC2 = 2 'Spalte B
NC = 3 'Spalte C; hier werden die neuen Daten geschrieben
Cr = 65536 'Suchbeginn für x-Zeilen in A
Nr = 1 'Schreibbeginn für String in Zeile1 in C
wks = "Tabelle1" 'Name der Tabelle wo die Daten stehen
Tstr = "" 'Variable für String zusammensetzung
ZStr = "" 'Variable um in Zelle zu schreiben
Header = 1 'Keine Überschriften vorhanden
Columns(NC).Select 'Neuer Spalte Textformat zuweisen
Selection.NumberFormat = "@"
Cells(1, 1).Select 'Start des Programms
If Worksheets(wks).Cells(Cr, CC) = "" Then
    Cr = Worksheets(wks).Cells(Cr, CC).End(xlUp).Row + 1
End If
Qe = MsgBox("Haben die Spalten einen Überschriftenbereich ?", vbCritical + vbYesNo + vbDefaultButton1, "Sortiervorgang")
'Hier werden die beiden Spalten noch sortiert
'das die Buchstaben mit etwas ordnung auftauchen :-)
If Qe = vbYes Then
    Worksheets(wks).Range(Cells(1, CC), Cells(Cr, CC2)).Sort Key1:=Range(Cells(1, CC)), _
    Order1:=xlAscending, Key2:=Range(Cells(1, CC2)), Order2:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase _
    :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
    DataOption2:=xlSortNormal
    Header = 2
    Nr = 2
Else
    Worksheets(wks).Range(Cells(1, 1), Cells(Cr, 2)).Sort Key1:=Range(Cells(1, CC)), _
    Order1:=xlAscending, Key2:=Range(Cells(1, CC2)), Order2:=xlAscending, _
    Header:=xlNo, OrderCustom:=1, MatchCase _
    :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
    DataOption2:=xlSortNormal
End If
'Beginn der Datensuche
Tstr = Worksheets(wks).Cells(Header, CC) & " " & Worksheets(wks).Cells(Header, CC2)
For i = Header + 1 To Cr
    If Worksheets(wks).Cells(i - 1, CC) <> Worksheets(wks).Cells(i, CC) Then
        Worksheets(wks).Cells(Nr, NC) = Tstr
        Tstr = Worksheets(wks).Cells(i, CC) & " " & Worksheets(wks).Cells(i, CC2)
        Nr = Nr + 1
    Else
        Tstr = Tstr & " " & Worksheets(wks).Cells(i, CC2)
    End If
Next i
End Sub
     Code eingefügt mit Syntaxhighlighter 1.14


Gruss Rainer


Anzeige
Re: Suchen und in nächste Spalte schreiben
01.11.2002 18:32:18
PeterW
Hallo Werner,

ich hab Deine Aufabe etwas anders verstanden und mit folgendem Code gelöst (der Bereich fängt bei A1 an):

Gruß
Peter

Re: Suchen und in nächste Spalte schreiben
01.11.2002 20:17:21
Erich
Hallo Ramses,

äußerst interessante Variante; ich erhalte allerdings bei "xlSortNormal" eine Fehlermeldung "Variable nicht definiert" - was muß ich tun?

Oder liegts an meiner EXCEL-Version?

mfg und besten Dank für eine Rückmeldung


Leichte Korrektur
01.11.2002 20:32:43
Ramses
Hallo Werner,

in der Tat war ein kleiner Fehler drin. Das Range Objekt im Sort-Key wurde von mir falsch definiert.
Hier die korrigierte Version

Sub Find_All_Characters()
Dim Cr As Long, CC As Integer, CC2 As Integer
Dim Nr As Long, NC As Integer
Dim Tstr As String, wks As String
Dim Qe As String, Header As Integer
CC = 1 'Spalte A
CC2 = 2 'Spalte B
NC = 3 'Spalte C; hier werden die neuen Daten geschrieben
Cr = 65536 'Suchbeginn für x-Zeilen in A
Nr = 1 'Schreibbeginn für String in Zeile1 in C
wks = "Tabelle1" 'Name der Tabelle wo die Daten stehen
Tstr = "" 'Variable für String zusammensetzung
ZStr = "" 'Variable um in Zelle zu schreiben
Header = 1 'Keine Überschriften vorhanden
Columns(NC).Select 'Neuer Spalte Textformat zuweisen
Selection.NumberFormat = "@"
Cells(1, 1).Select 'Start des Programms
If Worksheets(wks).Cells(Cr, CC) = "" Then
    Cr = Worksheets(wks).Cells(Cr, CC).End(xlUp).Row + 1
End If
Qe = MsgBox("Haben die Spalten einen Überschriftenbereich ?", vbCritical + vbYesNo + vbDefaultButton1, "Sortiervorgang")
'Hier werden die beiden Spalten noch sortiert
'das die Buchstaben mit etwas ordnung auftauchen :-)
If Qe = vbYes Then
    Worksheets(wks).Range(Cells(1, CC), Cells(Cr, CC2)).Sort Key1:=Cells(1, CC), _
    Order1:=xlAscending, Key2:=Cells(1, CC2), Order2:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase _
    :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
    DataOption2:=xlSortNormal
    Header = 2
    Nr = 2
Else
    Worksheets(wks).Range(Cells(1, 1), Cells(Cr, 2)).Sort Key1:=Cells(1, CC), _
    Order1:=xlAscending, Key2:=Cells(1, CC2), Order2:=xlAscending, _
    Header:=xlNo, OrderCustom:=1, MatchCase _
    :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
    DataOption2:=xlSortNormal
End If
'Beginn der Datensuche
Tstr = Worksheets(wks).Cells(Header, CC) & " " & Worksheets(wks).Cells(Header, CC2)
For i = Header + 1 To Cr
    If Worksheets(wks).Cells(i - 1, CC) <> Worksheets(wks).Cells(i, CC) Then
        Worksheets(wks).Cells(Nr, NC) = Tstr
        Tstr = Worksheets(wks).Cells(i, CC) & " " & Worksheets(wks).Cells(i, CC2)
        Nr = Nr + 1
    Else
        Tstr = Tstr & " " & Worksheets(wks).Cells(i, CC2)
    End If
Next i
End Sub
     Code eingefügt mit Syntaxhighlighter 1.14

Aber bei xlsort wird gar keine Variable verwendet !!!!???
Deshalb ist mir der Fehler schleierhaft.
Probier mal das aus, ob es jetzt geht.

Gruss Rainer

Anzeige

339 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige