Zeilen doppelter Zellen kombinieren...
25.07.2014 11:44:19
Erich
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
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
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich
