Microsoft Excel

Herbers Excel/VBA-Archiv

Zeilen doppelter Zellen kombinieren...

Betrifft: Zeilen doppelter Zellen kombinieren... von: Benni Schrader
Geschrieben am: 23.07.2014 22:50:50

Hallo zusammen,

ich suche nach einer Lösung für mein Problem das wie folgt aussieht:

http://img5.fotos-hochladen.net/uploads/syns13ad02g9rp8.jpg

ich habe in einem Tabellenblatt mit tausenden Zeilen, in jeder Zelle gleicher Zeile Synonyme eines Wortes (erste Abbildung). Nun tauchen einige der Synonyme in irgendeiner anderen Zeile nochmal auf. Die gefundene Zeile soll dann mit der ersteren zusammengefasst werden (zweite Abbildung):

http://img5.fotos-hochladen.net/uploads/syns2cbn9y06szp.jpg

Der Code soll also quasi alle Zellen des Tabellenblatts nach Duplikaten absuchen und bei Fund beide Zeilen der Duplikate zu einer Zeile machen.

Falls auch ohne viel Aufwand geht, sollten die gleichen Zeilen(nummern) anderer Tabellblätter wie die im achtivesheet zusammengefasst werden.

Ich bin für jede/n Hilfe/Tip/Ansatz dankbar!
gruss Benni

  

Betrifft: AW: Zeilen doppelter Zellen kombinieren... von: Daniel
Geschrieben am: 23.07.2014 22:56:51

wenn du jetzt die Beispieltabelle nicht als Bild, sondern als Exceldatei hochladen würdest, könnte man damit auch was anfangen.
Gruß Daniel


  

Betrifft: AW: Zeilen doppelter Zellen kombinieren... von: Benni Schrader
Geschrieben am: 23.07.2014 23:26:28

kommt sofort:

https://www.herber.de/bbs/user/91693.xlsm


  

Betrifft: Zeilen doppelter Zellen kombinieren... von: Erich G.
Geschrieben am: 25.07.2014 11:44:19

Hi Benni,
die erste Routine arbeitet nur auf dem Tabellenblatt "DE":

Option Explicit

Sub ZeilenZus()
   Dim aDic As Object, nDic As Object, lngQ As Long, lngC As Long, arQ
   Dim arC() As Long, arS() As Long, qq As Long, zz As Long, cc As Long
   Dim maxC As Long, arVz, arIz, ii As Long, arE() As String, rngD As Range

   Set aDic = CreateObject("Scripting.Dictionary")
   Set nDic = CreateObject("Scripting.Dictionary")
   With Sheets("DE")
      lngQ = .Cells(.Rows.Count, 1).End(xlUp).Row
      lngC = LetzteSpalteTab(Sheets(.Name))
      arQ = .Cells(1, 1).Resize(lngQ, lngC)           ' Quelldaten
      ReDim arC(1 To lngQ)                            ' Spaltenzahlen
      ReDim arS(1 To lngQ)                            ' Spaltenzahlen
      For qq = 1 To lngQ
         zz = 0
         For cc = 1 To lngC                           ' Spalten zählen
            If Trim(arQ(qq, cc)) = "" Then Exit For Else arS(qq) = arS(qq) + 1
         Next cc
         arC(qq) = arS(qq)
         For cc = 1 To arS(qq)                        ' Dubletten finden
            If aDic.Exists(arQ(qq, cc)) Then
               zz = aDic(arQ(qq, cc))                 ' Dubletten-Zeilennr.
               Exit For
            End If
         Next cc
         If zz Then                                   ' Dublette gefunden
            nDic(qq) = zz                             ' Zeile qq soll in Zeile zz
            ii = zz
         Else
            ii = qq
         End If
         For cc = 1 To arS(qq)
            aDic(arQ(qq, cc)) = ii                    ' Zielzeile zu allen Einträgen
         Next cc
      Next qq
      aDic.RemoveAll

      maxC = Application.Max(arC)                     ' Spaltenzahl der Zielmatrix
      arVz = nDic.Keys                                ' Verschiebung von Zeile
      arIz = nDic.Items                               ' Verschiebung in  Zeile
      For ii = 0 To UBound(arVz)
         zz = arIz(ii)
         arC(zz) = arC(zz) + arC(arVz(ii))
         If maxC < arC(zz) Then maxC = arC(zz)        ' Spaltenzahl der Zielmatrix
      Next ii
      ReDim arE(1 To lngQ, 1 To maxC)                 ' Zielmatrix deklarieren
      For qq = 1 To lngQ
         arC(qq) = arS(qq)
         For cc = 1 To arS(qq)
            arE(qq, cc) = arQ(qq, cc)                 ' Übertrag der Quelldaten
         Next cc
      Next qq

      Worksheets.Add Before:=Sheets(.Name)            ' neues Blatt für Ausgabe
      For ii = 0 To UBound(arVz)
         qq = arVz(ii)
         zz = arIz(ii)
         For cc = 1 To arS(qq)
            arE(zz, arC(zz) + cc) = arE(qq, cc)       ' Eintrag der Verschiebungen
         Next cc
         arC(zz) = arC(zz) + arS(qq)                  ' akt. Spaltenzahl erhöhen
         If ii = 0 Then
            Set rngD = Rows(qq)
         Else                                         ' Löschvorbereitung
            Set rngD = Union(rngD, Rows(qq))
         End If
      Next ii
      Cells(1, 1).Resize(UBound(arE), UBound(arE, 2)) = arE ' Ausgabe
      rngD.Delete
      Columns.AutoFit
   End With
End Sub

Function LetzteSpalteTab(wks As Worksheet) As Long
   Dim rng As Range

   With wks
      Set rng = .Cells.Find("*", .Cells(1, 1), xlValues, , xlByColumns, xlPrevious, , , False)
   End With
   If Not rng Is Nothing Then LetzteSpalteTab = rng.Column
End Function
Bei der zweiten Routine wird die Info, welche Zeilen in welche übertragen werden sollen,
von "DE" auf die anderen Blätter übertragen.
Die Zeilen können je nach Blatt unterschiedlich viele Einträge (Spalten) haben.

Ist das so unfähr das, was du haben wolltest?
Option Explicit

Sub ZeilenZusBlaetter()
   Dim aDic As Object, nDic As Object, lngQ As Long, lngC As Long, arQ
   Dim arC() As Long, arS() As Long, qq As Long, zz As Long, cc As Long
   Dim maxC As Long, arVz, arIz, ii As Long, arE() As String, rngD As Range
   Dim bb As Long

   Set aDic = CreateObject("Scripting.Dictionary")
   Set nDic = CreateObject("Scripting.Dictionary")
   With Sheets("DE")
      lngQ = .Cells(.Rows.Count, 1).End(xlUp).Row
      lngC = LetzteSpalteTab(Sheets(.Name))
      arQ = .Cells(1, 1).Resize(lngQ, lngC)           ' Quelldaten
      ReDim arC(1 To lngQ)                            ' Spaltenzahlen
      ReDim arS(1 To lngQ)                            ' Spaltenzahlen
      For qq = 1 To lngQ
         zz = 0
         For cc = 1 To lngC                           ' Spalten zählen
            If Trim(arQ(qq, cc)) = "" Then Exit For Else arS(qq) = arS(qq) + 1
         Next cc
         arC(qq) = arS(qq)
         For cc = 1 To arS(qq)                        ' Dubletten finden
            If aDic.Exists(arQ(qq, cc)) Then
               zz = aDic(arQ(qq, cc))                 ' Dubletten-Zeilennr.
               Exit For
            End If
         Next cc
         If zz Then                                   ' Dublette gefunden
            nDic(qq) = zz                             ' Zeile qq soll in Zeile zz
            ii = zz
         Else
            ii = qq
         End If
         For cc = 1 To arS(qq)
            aDic(arQ(qq, cc)) = ii                    ' Zielzeile zu allen Einträgen
         Next cc
      Next qq
      arVz = nDic.Keys                                ' Verschiebung von Zeile
      arIz = nDic.Items                               ' Verschiebung in  Zeile
      aDic.RemoveAll
   End With

   For bb = 1 To Worksheets.Count
      With Worksheets(bb)
         lngC = LetzteSpalteTab(Sheets(.Name))
         arQ = .Cells(1, 1).Resize(lngQ, lngC)           ' Quelldaten
         ReDim arC(1 To lngQ)                            ' Spaltenzahlen
         ReDim arS(1 To lngQ)                            ' Spaltenzahlen
         For qq = 1 To lngQ
            For cc = 1 To lngC                           ' Spalten zählen
               If Trim(arQ(qq, cc)) = "" Then Exit For Else arS(qq) = arS(qq) + 1
            Next cc
            arC(qq) = arS(qq)
         Next qq

         maxC = Application.Max(arC)                     ' Spaltenzahl der Zielmatrix
         For ii = 0 To UBound(arVz)
            zz = arIz(ii)
            arC(zz) = arC(zz) + arC(arVz(ii))
            If maxC < arC(zz) Then maxC = arC(zz)        ' Spaltenzahl der Zielmatrix
         Next ii
         ReDim arE(1 To lngQ, 1 To maxC)                 ' Zielmatrix deklarieren
         For qq = 1 To lngQ
            arC(qq) = arS(qq)
            For cc = 1 To arS(qq)
               arE(qq, cc) = arQ(qq, cc)                 ' Übertrag der Quelldaten
            Next cc
         Next qq

         For ii = 0 To UBound(arVz)
            qq = arVz(ii)
            zz = arIz(ii)
            For cc = 1 To arS(qq)
               arE(zz, arC(zz) + cc) = arE(qq, cc)       ' Eintrag der Verschiebungen
            Next cc
            arC(zz) = arC(zz) + arS(qq)                  ' akt. Spaltenzahl erhöhen
            If ii = 0 Then
               Set rngD = .Rows(qq)
            Else                                         ' Löschvorbereitung
               Set rngD = Union(rngD, .Rows(qq))
            End If
         Next ii
         .Cells(1, 1).Resize(UBound(arE), UBound(arE, 2)) = arE ' Ausgabe
         rngD.Delete
         .Columns.AutoFit
      End With
   Next bb
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


 

Beiträge aus den Excel-Beispielen zum Thema "Zeilen doppelter Zellen kombinieren..."