Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Tabellenzeilen zusammenfügen
zurück: Wie heißt "wähle Seite 1 aus" in Makro weiter: Daten in mehrere Tabellen schreiben. Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Feedback Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
micha86
Gast


Verfasst am:
10. Sep 2012, 18:39
Rufname:

Tabellenzeilen zusammenfügen - Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

Hallo!

Keine Ahnung ob sich das umsetzen lässt aber ich will folgendes erreichen:

Ich habe eine Tabelle in folgender Form
Code:
A      1       kk
B      3       tt
C       1       ee[/list]


Mein Ziel ist es,immer wenn in der 2ten Spalte der gleiche Wert steht (hier 1) will ich die Zeilen zusammenfassen. Die Spalten mit verschiedenen Werten sollen zusammen angezeigt werden.
Also so:

Code:
A, C      1      kk, ee
 B         3      tt


Ist das über ein Makro möglich? Und falls ja wie?
Ich hoffe ihr könnt mir helfen Very Happy
l.key
Excel (VBA) brauchbar


Verfasst am:
10. Sep 2012, 20:36
Rufname:


AW: Tabellenzeilen zusammenfügen - AW: Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

Hallo Micha,

lässt sich alles umsetzen:
Code:
Sub DeatenZusammenfuegen()
Dim objDicA As Object, objDicC As Object
Dim z As Long
    With Tabelle1    ' ggf. anpassen
        Set objDicA = CreateObject("Scripting.Dictionary")
        Set objDicC = CreateObject("Scripting.Dictionary")
        For z = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            If objDicA.Exists(.Cells(z, 2).Text) Then
                objDicA(.Cells(z, 2).Text) = objDicA(.Cells(z, 2).Text) & ", " & .Cells(z, 1)
                objDicC(.Cells(z, 2).Text) = objDicC(.Cells(z, 2).Text) & ", " & .Cells(z, 3)
            Else
                objDicA(.Cells(z, 2).Text) = .Cells(z, 1)
                objDicC(.Cells(z, 2).Text) = .Cells(z, 3)
            End If
        Next
        Sheets.Add After:=Sheets(.Index)
    End With
    Cells(1, 1).Resize(objDicA.Count) = WorksheetFunction.Transpose(objDicA.Items)
    Cells(1, 2).Resize(objDicA.Count) = WorksheetFunction.Transpose(objDicA.Keys)
    Cells(1, 3).Resize(objDicC.Count) = WorksheetFunction.Transpose(objDicC.Items)
End Sub

das Ergebnis wird in einem neuen Blatt angezeigt

_________________
Grüße, Klaus.
Gast



Verfasst am:
11. Sep 2012, 08:42
Rufname:

AW: Tabellenzeilen zusammenfügen - AW: Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

vielen Dank Very Happy Very Happy
werd ich gleich mal testen. Ich kenn mich nicht so gut mit VBA aus. Kannst du mir kurz erklären was die einzelnen Schritten im Makro bewirken?
Gast



Verfasst am:
11. Sep 2012, 11:50
Rufname:

AW: Tabellenzeilen zusammenfügen - AW: Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

gerade ist mir noch ein Problem aufgefallen. Angenommen in Spalte A oder C befinden sich auch dieselben Werte, dann sollen diese auch nur einmal angezeigt werden und nicht mehrfach mit Komma.
l.key
Excel (VBA) brauchbar


Verfasst am:
11. Sep 2012, 21:02
Rufname:


AW: Tabellenzeilen zusammenfügen - AW: Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

Hallo nochmals,

... das macht die Sache noch etwas komplizierter.
Code:
Sub DeatenZusammenfuegen()
Dim objDicA As Object, objDicC As Object, objDicA_Unikat As Object, objDicC_Unikat As Object
Dim strKey As String
Dim z As Long
    With Tabelle1    ' ggf. anpassen
        Set objDicA = CreateObject("Scripting.Dictionary")
        Set objDicC = CreateObject("Scripting.Dictionary")
        Set objDicA_Unikat = CreateObject("Scripting.Dictionary")
        Set objDicC_Unikat = CreateObject("Scripting.Dictionary")
        For z = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            strKey = .Cells(z, 2).Text
            If objDicA.Exists(strKey) Then
                If Not EintragVorhanden(objDicA_Unikat, strKey & "#" & .Cells(z, 1)) Then
                    objDicA(strKey) = objDicA(strKey) & ", " & .Cells(z, 1)
                End If
                If Not EintragVorhanden(objDicC_Unikat, strKey & "#" & .Cells(z, 3)) Then
                    objDicC(strKey) = objDicC(strKey) & ", " & .Cells(z, 3)
                End If
            Else
                objDicA(strKey) = .Cells(z, 1)
                objDicC(strKey) = .Cells(z, 3)
                objDicA_Unikat(strKey & "#" & .Cells(z, 1)) = 0
                objDicC_Unikat(strKey & "#" & .Cells(z, 3)) = 0
            End If
        Next
        Sheets.Add After:=Sheets(.Index)
    End With
    Cells(1, 1).Resize(objDicA.Count) = WorksheetFunction.Transpose(objDicA.items)
    Cells(1, 2).Resize(objDicA.Count) = WorksheetFunction.Transpose(objDicA.Keys)
    Cells(1, 3).Resize(objDicC.Count) = WorksheetFunction.Transpose(objDicC.items)
End Sub

Private Function EintragVorhanden(objDic As Object, strText As String) As Boolean
    If objDic.Exists(strText) Then
        EintragVorhanden = True
    Else
        objDic(strText) = 0
    End If
End Function

Grob erklärt: Der Code durchläuft alle gefüllten Zellen in B mit For ... Next
Um auf doppelte Einträge zu prüfen wird hier ein Dictionary-Objekt benutzt;
das ist so eine Art Wörterbuch, bei dem jeder Eintrag einen eindeutigen Schlüssel besitzt.
Man prüft also, ob der Schlüssel schon vorhanden ist,
~ falls nicht, wird ein Eintrag mit eben diesem Schlüssel erzeugt mit dem Wert aus Spalte A bzw. C,
~ falls doch, dann wird der alte Eintrag zu diesem Schlüssel mit dem neuen Wert erweitert.
Um auch deinen letzten Wunsch zu erfüllen habe ich noch zwei weitere Dictionary-Objekte hinzugefügt, die jeweils beim Durchlaufen der Zeilen überprüfen,
ob die Kombination aus Spalte B und A bzw. C schon vorgekommen ist. Diesen Teil habe ich in eine Function gepackt.
Zum Schluss werden die Werte und Schlüssel der Dictionary-Objekte in eine neue Tabelle übertragen.

Alles klar?

_________________
Grüße, Klaus.
Phelan XLPH
Fortgeschritten


Verfasst am:
12. Sep 2012, 08:18
Rufname: Phelan

AW: Tabellenzeilen zusammenfügen - AW: Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

Das Dictionary stößt an seine Grenzen bei einer Zeichenlänge > 256!

Code:
Sub x()
    Dim ar As Variant
    Dim arZ As Variant
    Dim arT As Variant
    Dim arE As Variant
    Dim arV() As Long
    Dim i As Long
    Dim n As Long
    Dim k As Long
    Dim T As String  'Trenner
   
    T = ", "
   
    With Tabelle1.Cells(1).CurrentRegion
        ar = .Value
        ReDim arZ(1 To WorksheetFunction.Max(.Columns(2)))
    End With
   
    For i = 1 To UBound(ar)
        arZ(ar(i, 2)) = arZ(ar(i, 2)) & T & i
    Next
   
    ReDim arE(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 1 To UBound(arZ)
        If arZ(i) <> "" Then
            arT = Split(Mid(arZ(i), 2), T)
            k = k + 1
            For n = LBound(arT) To UBound(arT)
                If arE(k, 2) = Empty Then
                    arE(k, 1) = ar(arT(n), 1)
                    arE(k, 2) = i
                    arE(k, 3) = ar(arT(n), 3)
                Else
                    'If InStr(T & arE(k, 1) & T, T & ar(arT(n), 1) & T) = 0 Then _
                    'arE(k, 1) = arE(k, 1) & T & ar(arT(n), 1)
                    If Not T & arE(k, 1) & T Like "*" & T & ar(arT(n), 1) & T & "*" Then _
                    arE(k, 1) = arE(k, 1) & T & ar(arT(n), 1)
                    'If InStr(T & arE(k, 3) & T, T & ar(arT(n), 3) & T) = 0 Then _
                    'arE(k, 3) = arE(k, 3) & T & ar(arT(n), 3)
                    If Not T & arE(k, 3) & T Like "*" & T & ar(arT(n), 3) & T & "*" Then _
                    arE(k, 3) = arE(k, 3) & T & ar(arT(n), 3)
                End If
            Next
        End If
    Next
   
    For i = 1 To k
        arT = Split(arE(i, 1), T)
        Call QSort(arT, LBound(arT), UBound(arT))
        arE(i, 1) = Join(arT, T)

        arT = Split(arE(i, 3), T)
        ReDim ar(UBound(arT))
        For n = 0 To UBound(ar)
            ar(n) = Val(arT(n))
        Next
        Call QSort(ar, LBound(ar), UBound(ar))
        arE(i, 3) = Join(ar, T)
    Next
   
    Tabelle1.Cells(6).Resize(k, UBound(arE, 2)) = arE
End Sub

Sub QSort(ByRef ar, low, hi)
    Dim i, j, p
    While low < hi
        p = ar(hi)
        i = low - 1
        For j = low To hi - 1
            If ar(j) <= p Then
                i = i + 1
                Swap ar, i, j
            End If
        Next
        Swap ar, i + 1, j
        QSort ar, low, i
        low = i + 2
    Wend
End Sub
Sub Swap(ByRef ar, first, second)
    Dim T
    T = ar(first)
    ar(first) = ar(second)
    ar(second) = T
End Sub
Gast



Verfasst am:
12. Sep 2012, 09:26
Rufname:

AW: Tabellenzeilen zusammenfügen - AW: Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

Wow hast dir ja echt Mühe gegeben....vielen Dank für deine Hilfe das hätte ich alleine auf keinen Fall hinbekommen. Echt super! Very Happy
l.key
Excel (VBA) brauchbar


Verfasst am:
12. Sep 2012, 20:24
Rufname:

AW: Tabellenzeilen zusammenfügen - AW: Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

Hallo Phelan,

Zitat:
Das Dictionary stößt an seine Grenzen bei einer Zeichenlänge > 256!

wußte ich nicht, danke für die Aufklärung.
Prima Lösung übrigens, und alles schön sortiert.

_________________
Grüße, Klaus.
slowboarder
Im Profil kannst Du frei den Rang ändern


Verfasst am:
12. Sep 2012, 21:35
Rufname:


AW: Tabellenzeilen zusammenfügen - AW: Tabellenzeilen zusammenfügen

Nach oben
       Version: Office 2003

Hi
wenn die Zeichenlänge von 256 Zeichen ein Problem darstellt, könntest du es auch so versuchen:

Code:

Sub test()
With ActiveSheet.UsedRange
    .Sort , Header:=xlYes, _
        key1:=.Cells(2, 2), order1:=xlAscending, _
        key2:=.Cells(2, 1), order2:=xlAscending, _
        key3:=.Cells(2, 3), order3:=xlAscending
   
    With .Columns(.Columns.Count).Offset(1, 1).Resize(.Rows.Count - 1, 3)
        .Columns(1).FormulaR1C1 = "=IF(RC2<>R[-1]C2,RC1,IF(ISERROR(FIND("", ""&RC1&"", "","", ""&R[-1]C&"", "")),R[-1]C&"", ""&RC1,R[-1]C))"
        .Columns(3).FormulaR1C1 = "=IF(RC2<>R[-1]C2,RC3,IF(ISERROR(FIND("", ""&RC3&"", "","", ""&R[-1]C&"", "")),R[-1]C&"", ""&RC3,R[-1]C))"
        .Columns(2).FormulaR1C1 = "=IF(RC2=R[1]C2,True,RC2)"
        .Copy
        .Offset(0, 1 - .Column).PasteSpecial xlPasteValues
        .ClearContents
    End With
    .Sort key1:=.Cells(1, 2), order1:=xlAscending, Header:=xlYes
    .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
End With
End Sub


der Code sortiert erst die Daten und stellt dann die Werte per Formel zusammen.
am schluss werden dann die nicht mehr benötigten Zeilengelöscht.

Gruß Daniel
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: Felder zusammenfügen 4 Bernett22 287 14. Feb 2011, 11:39
Bernett22 Felder zusammenfügen
Keine neuen Beiträge Excel Formeln: einzelne Inhalte vergleichen, in einer zelle zusammenfügen 4 ewoxi 208 25. Nov 2010, 18:01
ewoxi einzelne Inhalte vergleichen, in einer zelle zusammenfügen
Keine neuen Beiträge Excel Formeln: Texte aus Zellen einer Spalte in eine Zeile zusammenfügen? 9 Bastimania 811 10. Aug 2010, 15:29
MAckl Texte aus Zellen einer Spalte in eine Zeile zusammenfügen?
Keine neuen Beiträge Excel Formeln: 2 Textspalten in einer Spalte zusammenfügen 1 Cethegus 895 08. Jul 2010, 17:24
Klaus-Dieter 2 Textspalten in einer Spalte zusammenfügen
Keine neuen Beiträge Excel Formeln: Zellen zu einer Verknüpfung zusammenfügen 12 kubebe 1243 24. Feb 2010, 16:36
kubebe Zellen zu einer Verknüpfung zusammenfügen
Keine neuen Beiträge Excel Formeln: Einzele Excel-Dateine in eine Zusammenfügen 1 Kattl 200 21. Feb 2010, 16:37
shift-del Einzele Excel-Dateine in eine Zusammenfügen
Keine neuen Beiträge Excel Formeln: 2x errechnetes Datum in eine Zelle zusammenfügen 2 Hoschi81 283 01. Feb 2010, 10:49
Hoschi81 2x errechnetes Datum in eine Zelle zusammenfügen
Keine neuen Beiträge Excel Formeln: Tabellen zusammenfügen / Kopieren und mit komma trennen 4 meyer 1410 20. Okt 2009, 09:30
meyer Tabellen zusammenfügen / Kopieren und mit komma trennen
Keine neuen Beiträge Excel Formeln: Zelleninhalte zusammenfügen / trennen 3 Itchkopf 4370 01. Okt 2009, 12:35
KV17uwe Zelleninhalte zusammenfügen / trennen
Keine neuen Beiträge Excel Formeln: in einer mappe mehrere zusammenfügen? 1 egon22e 312 29. Jul 2009, 10:00
Gast in einer mappe mehrere zusammenfügen?
Keine neuen Beiträge Excel Formeln: Tabellen zusammenfügen 0 Kilton 7972 818 20. Jun 2009, 13:27
Kilton 7972 Tabellen zusammenfügen
Keine neuen Beiträge Excel Formeln: werte zusammenfügen 1 whoeva 396 07. Aug 2008, 10:52
licht werte zusammenfügen
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Excel Tipps