Datensätze zusammenfassen (Bsp. v. Erich G.)
18.12.2008 18:00:52
Dieter
(@hallo Erich G.)
habe mal von Erich dieses Beispiel bekommen. Funktioniet prima. der Code soll Datensätze zusammenfügen, die in der Spalte B den gleichen Eintrag haben.
Die gleichen Einträge bis zu 20 Zeichen lang sein. NUn meine Frage dazu:
Kann man den Code so ändern, dass NUR die ersten 12 Zeichen angeschaut weden. Also es sollen nur die ersten 12 Zeichen eines jeden Eintrags in Spalte B verglichen werden und bei übereinstimmung sollen diese zusammengeführt weden. Hier nochmal des Bsp von Erich:
Gruss
Dieter
Option Explicit
Sub DatenZusammenfassen()
Dim wks As Worksheet
' Zeilenvariablen definieren .
Dim intAR As Integer
Dim intFR As Integer
Dim intLR As Integer
Dim intR As Integer
Dim strSuchtext As String
Dim rngSuchBereich As Range
' benötigte Spaltenkonstanten bestimmen .
Const ColB As Integer = 2
Const ColL As Integer = 12
Const ColP As Integer = 16
Const ColS As Integer = 19
Const ColAB As Integer = 42
Const ColBB As Integer = 54
Const ColBK As Integer = 63
' Aktives Tabellenblatt definieren .
Set wks = ActiveWorkbook.Sheets("Tabelle1")
' Letzte Zeile ermitteln .
intFR = 10
intLR = wks.UsedRange.Rows.Count
' Zeilendurchlauf .
For intR = intFR To intLR
strSuchtext = wks.Cells(intR, ColB)
If strSuchtext > "" Then
Set rngSuchBereich = wks.Range(Cells(intR + 1, ColB), Cells(intLR, ColB))
' weiterer Eintrag vorhanden? .
While WorksheetFunction.CountIf(rngSuchBereich, strSuchtext) > 0
intAR = WorksheetFunction.Match(strSuchtext, rngSuchBereich, 0)
intAR = intR + intAR
' 1. Eintrag aktualisieren .
' Addition
wks.Cells(intR, ColL).Value = wks.Cells(intR, ColL).Value _
+ wks.Cells(intAR, ColL).Value
wks.Cells(intR, ColS).Value = wks.Cells(intR, ColS).Value _
+ wks.Cells(intAR, ColS).Value
wks.Cells(intR, ColAB).Value = wks.Cells(intR, ColAB).Value _
+ wks.Cells(intAR, ColAB).Value
wks.Cells(intR, ColBB).Value = wks.Cells(intR, ColBB).Value _
+ wks.Cells(intAR, ColBB).Value
wks.Cells(intR, ColBK).Value = wks.Cells(intR, ColBK).Value _
+ wks.Cells(intAR, ColBK).Value
' Text
wks.Cells(intR, ColP).Value = wks.Cells(intR, ColP).Value & "; " _
& wks.Cells(intAR, ColP).Value
' 2. Eintrag löschen
Debug.Print Cells(Rows.Count, 2).End(xlUp).Address
Debug.Print Sheets("GeloeschteDaten").Cells(Rows.Count, 2).End(xlUp).Address
Rows(intAR).Copy _
Sheets("GeloeschteDaten").Cells(Rows.Count, 2).End(xlUp).Offset(1, -1)
Rows(intAR).Delete Shift:=xlUp
intLR = intLR - 1
Wend
End If
Next intR
' Objektvariablen aufheben .
Set wks = Nothing
Set rngSuchBereich = Nothing
End Sub