Microsoft Excel

Herbers Excel/VBA-Archiv

Tabelle umformen



Excel-Version: 8.0 (Office 97)

Betrifft: Tabelle umformen
von: Bernd
Geschrieben am: 08.06.2002 - 21:55:09


Hallo,

ich habe eine Excel-Tabelle mit folgendem Inhalt (meine echte Tabelle enthält etwa 16000 Zeilen):























Spalte A


Spalte B


Meyer


01067


Meyer


02829


Meyer


02936


Schmidt


56387


Schmidt


56398


Müller


26589


Müller


26547


Müller


26598


Müller


27895

Die echte Tabelle enthält noch weitere Namen und Zahlen. Die Häufigkeit der einzelnen Namen ist unterschiedlich.


Den Inhalt aus Tabelle 1 muß ich in die Form von Tabelle 2 konvertieren.













Spalte A


Spalte B


Meyer


01067, 02829, 02936


Schmidt


56387, 56398


Müller


26589, 26547, 26598, 27895

Weiß jemand, wie man die Tabelle automatisch in die benötigte Form konvertieren kann?


 




  

Re: Tabelle umformen
von: Ramses
Geschrieben am: 09.06.2002 - 00:29:13

Hallo Bernd,

füge diesen Code in ein Modul ein, und passe die entsprechenden Variablen noch auf deine Bedürfnisse an.
Im Test lief es ganz gut:


Sub Convert_Tabelle()
Dim As Integer, n As Integer
Dim cr As Long, targetCr As Long, TargetSuche As Long
Dim wks1 As String, wks2 As String, Target As String
Dim Suchname As String
Dim FindText As String
'Das musst du anpassen:
'Namen der Tabelle
wks1 = "Tabelle1"
wks2 = "Tabelle2"
Target = "A:A"
FindText = ""
TargetSuche = 0
cr = 65536
If Worksheets(wks1).Cells(cr, 1) = "" Then
    cr = Worksheets(wks1).Cells(cr, 1).End(xlUp).Row
End If
For i = 1 To cr
    Suchname = Worksheets(wks1).Cells(i, 1)
    Debug.Print "Suchname " & Suchname
    On Error GoTo SuchError
    Worksheets(wks2).Cells.Find(What:=Suchname, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
WeiterI:
Next i
Suchexit:
Exit Sub

SuchError:
Select Case Err
    Case 91
        For n = 1 To cr
            If Worksheets(wks1).Cells(n, 1) = Suchname Then
                FindText = FindText & Worksheets(wks1).Cells(n, 2) & ", "
                Debug.Print "Suchtext " & FindText
            End If
        Next n
        targetCr = Worksheets(wks2).Cells(65536, 1).End(xlUp).Row
        Debug.Print "TargetCr " & targetCr
        Worksheets(wks2).Cells(targetCr + 1, 1) = Suchname
        Worksheets(wks2).Cells(targetCr + 1, 2) = FindText
        Suchname = ""
        FindText = ""
    TargetSuche = 0
    Resume WeiterI
End Select
Resume Suchexit
End Sub

Viel Spass.

Gruss Rainer

  

Kommando zurück...
von: Ramses
Geschrieben am: 09.06.2002 - 00:32:38

Habe gerade noch einen Fehler entdeckt.
Es tut nicht so wie ich will.

Sorry.
Gruss RAiner


  

Tut doch, .... aber
von: Ramses
Geschrieben am: 09.06.2002 - 00:38:57

Hallo Bernd,

ein kleiner Haken und ich komm nicht drauf.
Das Makro funkioniert nur, wenn es von der Tabelle aus aufgerufen wird, in welche die Daten eingefügt werden sollen (Tabelle2)!?
Ansonsten bricht das Makro nach dem ersten Namen ab.
Keine Ahnung wieso,... aber mit dem Workaround funktioniert es.

Gruss Rainer


  

Re: Kommando zurück...
von: Bernd
Geschrieben am: 09.06.2002 - 06:20:39

Hallo Rainer,

zunächst erst einmal vielen Dank für Deine Bemühungen. Ich habe
den Code in ein Modul eingegeben. Anschließend habe ich das
Makro aus Tabelle 2 heraus gestartet. Danach kommt immer folgende Fehlermeldung: Index außerhalb des gültigen Bereichs.

Gruß
Bernd

  

Re: Kommando zurück...
von: Hajo
Geschrieben am: 09.06.2002 - 06:38:16

Halo Bernd

ich habe de Code gerade unter XP getestet (Rainer verwendet auch XP) und wenn die Tabelle2 die aktive ist läuft der Code bei mir Fehlerfrei. Schreibe doch mal in welcher Zeile der Fehler kommt. Bei mir stehen Deine Daten ab erste Zeile ohne Überschrift in Tabelle1 und in Tabelle2 stehen Sie ab 2 Zeile.

Ich wollte nur mein Ergebnis mitteilen, lösen muß es Rainer wahrscheinlich selbst. Es ist immer kompliziert sich in einen anderen Code einzuarbeite. Es hat jeder so seine besonderen Noten beim programmieren.

Gruß Hajo


  

Re: Kommando zurück...
von: Bernd
Geschrieben am: 09.06.2002 - 07:22:42

Hallo Hajo,

ich kenne mich leider mit Makros und VBA nicht so gut aus. Ich habe daher fälschlicher Weise 2 Excel-Tabellen (2 Dateien) erstellt. Dann habe ich das Makro aus der Tabelle 2 heraus gestartet und es kam zur Fehlermeldung "Index außerhalb des gültigen Bereichs". Wenn ich nur eine Datei mit den Tabellenblättern "Tabelle1" und "Tabelle2" erstelle und den Code aus dem Tabellenblatt "Tabelle2" heraus starte, kommt es nicht mehr zur o. a. Fehlermeldung. Leider bleibt aber das Tabellenblatt "Tabelle2" nach Ausführung des Codes leer. Was mache ich falsch?

Gruß
Bernd


  

Re: Kommando zurück...
von: Hajo
Geschrieben am: 09.06.2002 - 07:27:32

Hallo Bernd

das ist mir zu viel Mühe mich in Rainer sein Makro einzuarbeiten, wobei es bei mir Fehlerfrei läuft.

Das 2 Register hat tatsächlich den Namen Tabelle2 ohne Leerzeichen???
Den Code hast Du aus dem Forum kopiert nicht neu eingegeben???

Gruß Hajo


  

Re: Kommando zurück...
von: Bernd
Geschrieben am: 09.06.2002 - 07:47:22

Hallo Hajo,

den Code habe ich aus dem Forum kopiert und eingefügt.
Das 2. Register heißt Tabelle2 (ohne Leerzeichen).

Trotzdem vielen Dank für Deine Mithilfe!

Gruß
Bernd


  

Re: Kommando zurück...
von: Hajo
Geschrieben am: 09.06.2002 - 08:09:30

Hallo Bernd
vielleicht mal ein anderer Ansatz.
Namen in Spalte A , Nummern in Spalte B
Sub Zusammen()
    Dim Letzte1 As Long
    Dim Letzte2 As Long
    Dim As Integer
    Dim Zelle
    If Worksheets("Tabelle1").Range("a65536") = "" Then
        Letzte1 = Worksheets("Tabelle1").Range("a65536").End(xlUp).Row
    Else
        Letzte1 = 65536
    End If
    For I = 1 To Letzte1
        With Worksheets("Tabelle2")
            If .Range("a65536") = "" Then
                Letzte2 = .Range("a65536").End(xlUp).Row
            Else
                Letzte2 = 65536
            End If
            Set Zelle = .Range("A1:A" & Letzte2).Find(What:=Worksheets("Tabelle1").Cells(I, 1), LookAt:=xlWhole)
            If Not Zelle Is Nothing Then
            '   Name gefunden
                .Cells(Zelle.Row, 2) = .Cells(Zelle.Row, 2) & ", " & Worksheets("Tabelle1").Cells(I, 2)
            Else
            ' Namen nicht gefunden
                .Cells(Letzte2 + 1, 1) = Worksheets("Tabelle1").Cells(I, 1)
                .Cells(Letzte2 + 1, 2) = Worksheets("Tabelle1").Cells(I, 2)
            End If
        End With
    Next I
End Sub

Gruß Hajo

  

Re: Tabelle umformen
von: WernerB.
Geschrieben am: 09.06.2002 - 10:18:29

Hallo Bernd,

teste doch mal dieses Makro.
Die Ursprungsdaten werden im Blatt "Tabelle1" erwartet.
Es wird ein neues Blatt angehängt, auf dem Du die gewünschte Zusammenfassung findest.


Option Explicit
Sub Komprimieren()
Dim As Range
Dim za1 As String, za2 As String, w As String
Dim As Long, laR As Long
Dim farb As Boolean
    Application.ScreenUpdating = False
    Sheets.Add After:=Sheets(Sheets.Count)
    laR = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
    Sheets("Tabelle1").Range("A1:B" & laR).Copy
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    za2 = Cells(laR, 1).Address(False, False)
    For i = 1 To laR
      za1 = Cells(i, 1).Address(False, False)
      w = ""
      farb = False
      For Each c In Range(za1 & ":" & za2)
        If c.Interior.ColorIndex <> 46 And c.Value = Cells(i, 1).Value Then
          c.Interior.ColorIndex = 46
          w = w & c.Offset(0, 1).Text & ", "
          farb = True
        End If
      Next c
      If farb = True Then
        Cells(i, 1).Interior.ColorIndex = 0
        Cells(i, 2).Value = Left(w, Len(w) - 2)
      End If
    Next i
    For i = laR To Step -1
      If Cells(i, 1).Interior.ColorIndex = 46 Then _
        Cells(i, 1).EntireRow.Delete
    Next i
    laR = Cells(Rows.Count, 1).End(xlUp).Row
    Columns("A:B").EntireColumn.AutoFit
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub

Viel Erfolg wünscht
WernerB.
  

Voraussetzungen
von: Ramses
Geschrieben am: 09.06.2002 - 10:55:40

Hallo Bernd,

Nach deiner Beschreibung ( 2 Tabellen ) bin davon ausgegangen, dass beide Tabellen in der gleichen Arbeitsmappe sind.
Wenn deine Daten in einer anderen Arbeitsmappe sind, funktioniert es logischerweise nicht.

Es ist mir ehrlich gesagt zu aufwändig das ganz jetzt noch umzuprogrammieren.
Erstelle in deiner Mappe mit deinen Daten eine neue Tabelle und bennene sie mit "Tabelle2", kopiere den Code in diese Arbeitsmappe. Aktiviere die "Tabelle2" und wähle "Extras - Makro - Makros ausführen" und starte dort das Makro. Dann geht es.
Diese Tabelle mit den geänderten Daten kannst du ja dann in eine andere Arbeitsmappe verschieben oder kopieren.

Ich habe dir noch eine Musterdatei gesandt.

Gruss Rainer


  

Re: Kommando zurück...
von: Ramses
Geschrieben am: 09.06.2002 - 11:02:10

Hallo Hajo,

Dein Konstrukt gefällt mir besser.
Meines ist eine Notlösung mit der Fehlernummer.
Ich wollte eigentlich mit "MATCH" arbeiten, habe aber immer wieder einen Fehler erhalten ( "Matchfunktion kann nicht zugeordnet werden ") obwohl der Inhalt vorhanden war.
keine Ahnung warum. Irgendwann habe ich dann heute nacht einfach was gestellt das funktioniert.
Das ist nicht mein regulärer Programmierstil. Das glaube ich dir gerne, dass du dich da nicht einarbeiten willst. *lol*
Sauber ist es nicht,... aber es hat zumindest funktioniert :-))

Gruss Rainer

  

Re: Kommando zurück...
von: Hajo
Geschrieben am: 09.06.2002 - 11:09:03

Hallo Ramses

das war kein Kritik am Programmstil. Aber jeder hat seine eigenen Programmstil und in eine vorhandenes Programm einarbeiten kostet doch ein wenig Zeit und ich habe gehofft bzw. wußte das Du noch mal ins Forum rein schaust. Der Ersteller kann am einfachsten den Code änden.

Gruß Hajo


  

Re: Kommando zurück...
von: Bernd
Geschrieben am: 09.06.2002 - 12:13:28

Hallo Hajo,

es funktioniert. Läuft super. Vielen, vielen Dank!!!

Gruß
Bernd


  

Re: Tabelle umformen
von: Bernd
Geschrieben am: 09.06.2002 - 12:17:50

Hallo Werner,

mit Deinem Makro funktioniert es. Vielen, vielen Dank!

Gruß
Bernd


  

Re: Voraussetzungen
von: Bernd
Geschrieben am: 09.06.2002 - 12:30:01

Hallo Rainer,

ich habe Deine Tabelle erhalten und das Makro (Convert_Tabelle) ausprobiert. Ich weiß nicht was ich falsch mache, aber auf meinem Rechner bleibt die Tabelle2 nach Ausführung des Makros leer. Ich habe jetzt den Code von Hajo und Werner ausprobiert. Mit diesen Lösungen erhalte ich auf meinem Rechner das gewünschte Ergebnis.

Vielen, vielen Dank für Deine Hilfe.

Gruß
Bernd


 

Beiträge aus den Excel-Beispielen zum Thema "Tabelle umformen"