Function Verketten2(ByRef bereich As Range, Trennzeichen As String) As String
Dim rng As Range
For Each rng In bereich
If rng <> "" Then
Verketten2 = Verketten2 & rng & Trennzeichen
End If
Next
If Len(Verketten2) > 0 Then _
Verketten2 = Left(Verketten2, Len(Verketten2) - Len(Trennzeichen))
End Function
GrußFunction Verketten88(ByRef bereich As Range, Trennzeichen As String) As Long
Dim rng As Range
For Each rng In bereich
If rng <> "" Then
Verketten88 = Verketten88 & rng & Trennzeichen
End If
Next
If Len(Verketten88) > 0 Then _
Verketten88 = Len(Verketten88) - Len(Trennzeichen)
End Function
Gruß GerdFunction Verketten3(ByRef bereich As Range, Trennzeichen As String) As Variant
Dim rng As Range
Dim arr(1) As String
Dim maxL As Long
maxL = 32767
For Each rng In bereich
If rng <> "" Then
Verketten3 = Verketten3 & rng & Trennzeichen
End If
Next
If Len(Verketten3) > 0 Then
If Len(Verketten3) > maxL Then
arr(0) = Left(Verketten3, Len(Verketten3) - _
Len(Trennzeichen) - (Len(Verketten3) - maxL - 1))
arr(1) = Right((Left(Verketten3, Len(Verketten3) - _
Len(Trennzeichen))), Len(Left(Verketten3, _
(Len(Verketten3) - Len(Trennzeichen)) - maxL)))
Else
arr(0) = Left(Verketten3, Len(Verketten3) - Len(Trennzeichen))
End If
Verketten3 = arr
End If
End Function
Function Verketten3(ByRef bereich As Range, _
Trennzeichen As String, _
Optional PosNr As Long = 1, _
Optional MaxLänge As Long = 32768) As String
Dim Erg() As String
Dim rng As Range
Dim i As Long
i = 0
ReDim Erg(i)
For Each rng In bereich
If rng <> "" Then
If Len(Erg(i) & Trennzeichen & rng) > MaxLänge Then
i = i + 1
If i = PosNr Then Exit For
ReDim Preserve Erg(i)
End If
Erg(i) = Erg(i) & Trennzeichen & rng
End If
Next
If (PosNr - 1) > i Then
Verketten3 = ""
Else
Verketten3 = Mid(Erg(PosNr - 1), Len(Trennzeichen) + 1)
End If
End Function
hierbei kannst du zwei weiter Parameter angeben:
Sub xFiles()
' Tabellenname > ggf. Anpassen
With ThisWorkbook.Worksheets("Tabelle1")
' Datenbereich > ggf. anpassen!
Dim rng As Range
Set rng = .Range("A1:E16")
' Spalte ab der die ermittelten Wert eingetragen werden sollen (M)
Dim lTargetColum As Long
lTargetColum = 13
Dim lColumnKey1 As Long
Dim lColumnKey2 As Long
Dim lColumnValue As Long
' Spaltendefinitionen
lColumnKey1 = 1 '(A)
lColumnKey2 = 5 '(E)
lColumnValue = 4 '(D)
Dim ArrayList01 As New ArrayList
Set ArrayList01 = CreateObject("system.collections.arraylist")
Dim strKeyAE As String
Dim strValueD As String
' Zeile in der Range
Dim r As Variant
Dim x(1) As String
' Alle Zeilen in a1 : E16 durchlaufen
For Each r In rng.Rows
' Wert aus jew. Zeile und Spalte D
strValueD = r.Cells(1, lColumnValue).Value
' Nur die Zeilen verarbeiten, in denen Spalte 4 (D) nicht leer ist
If Not strValueD = "" Then
' Schlüssel aus Spalte 1(A) und 5 (E) bilden
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
' Schlüssel und Wert dem Array x zuweisen
x(0) = strKeyAE
x(1) = strValueD
' Array einer ArrayList ArrayList01 zuweisen
ArrayList01.Add x
End If
Next r
' Range nochmal durchlaufen
For Each r In rng.Rows
c = 0
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
For Each j In ArrayList01
If strKeyAE = j(0) Then
r.Cells(1, lTargetColum + c).Value = j(1)
c = c + 1
End If
Next j
Next r
End With
End Sub
VG, Ch.Option Explicit
Sub xFiles()
' Tabellenname > ggf. Anpassen
With ThisWorkbook.Worksheets("Tabelle1")
' Schalter für Wiederholungen (False/True)
Dim blnDublikate As Boolean
blnDublikate = False
' Datenbereich > ggf. anpassen!
Dim rng As Range
Set rng = .Range("A1:E16")
' Spalte ab der die ermittelten Wert eingetragen werden sollen (M)
Dim lTargetColum As Long
lTargetColum = 13
Dim lColumnKey1 As Long
Dim lColumnKey2 As Long
Dim lColumnValue As Long
' Spaltendefinitionen
lColumnKey1 = 1 '(A)
lColumnKey2 = 5 '(E)
lColumnValue = 4 '(D)
Dim ArrayList01 As New ArrayList
Set ArrayList01 = CreateObject("system.collections.arraylist")
Dim strKeyAE As String
Dim strValueD As String
' Zeile in der Range
Dim r As Variant
' Array für Key u. Value
Dim x(1) As String
' Alle Zeilen in a1 : E16 durchlaufen
For Each r In rng.Rows
' Wert aus jew. Zeile und Spalte D
strValueD = r.Cells(1, lColumnValue).Value
' Nur die Zeilen verarbeiten, in denen Spalte 4 (D) nicht leer ist
If Not strValueD = "" Then
' Schlüssel aus Spalte 1(A) und 5 (E) bilden
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
' Schlüssel und Wert dem Array x zuweisen
x(0) = strKeyAE
x(1) = strValueD
' Array einer ArrayList ArrayList01 zuweisen
ArrayList01.Add x
End If
Next r
' Spaltenfortschritt
Dim c As Long
' Item d. ArrayListObjects
Dim j As Variant
' Werte bei jedem Key ausgeben (mit Dublikaten)
If blnDublikate = True Then
' Range nochmal durchlaufen
For Each r In rng.Rows
c = 0
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
For Each j In ArrayList01
If strKeyAE = j(0) Then
r.Cells(1, lTargetColum + c).Value = j(1)
'r.Cells(1, lTargetColum + c).Interior.Color = rgbYellow
c = c + 1
End If
Next j
Next r
' Werte nur beim ersten Vorkommen ausgeben (ohne Dublikate)
' blnDublikate = False
Else
' ArrayList zum Merken der Verarbeiteten Schlüssel
Dim ArrayListOc As New ArrayList
Set ArrayListOc = CreateObject("system.collections.arraylist")
For Each r In rng.Rows
c = 0
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
' Abgearbeiteten Schlüssel merken
With ArrayListOc
If Not .Contains(strKeyAE) Then
.Add strKeyAE
For Each j In ArrayList01
If strKeyAE = j(0) Then
r.Cells(1, lTargetColum + c).Value = j(1)
'r.Cells(1, lTargetColum + c).Interior.Color = rgbViolet
c = c + 1
End If
Next j
End If
End With
Next r
End If
End With
End Sub
VG, Ch.As New ArrayList
As Object
kommt in der lezten Version des Prgr. 2 mal vor! ' Datenbereich > ggf. anpassen!
Dim rng As Range
'Set rng = .Range("A1:E16")
Set rng = .Range("A1").CurrentRegion.Resize(, 6)
Die anderen Features die du dir wünschst,sind auch alle machbar.Bevor jemand das angeht, sollte das bisher Erstellte aber korrekt funktionieren! Btw. cool wäre es auch wenn du mal kurz erläuterst, wozu bzw. für was das ganze gut ist ...r.Cells(1, lTargetColum + c).Interior.Color = rgbViolet
Option Explicit
Sub xFiles()
' Tabellenname > ggf. Anpassen
With ThisWorkbook.Worksheets("Tabelle1")
' Schalter für Wiederholungen (False/True)
Dim blnDublikate As Boolean
blnDublikate = False
' Datenbereich > ggf. anpassen!
Dim rng As Range
'Set rng = .Range("A1:E16")
Set rng = .Range("A1").CurrentRegion.Resize(, 6)
' Spalte ab der die ermittelten Wert eingetragen werden sollen (M)
Dim lTargetColum As Long
lTargetColum = 13
Dim lColumnKey1 As Long
Dim lColumnKey2 As Long
Dim lColumnValue As Long
' Spaltendefinitionen
lColumnKey1 = 1 '(A)
lColumnKey2 = 5 '(E)
lColumnValue = 4 '(D)
Dim ArrayList01 As Object 'New ArrayList
Set ArrayList01 = CreateObject("system.collections.arraylist")
Dim strKeyAE As String
Dim strValueD As String
' Zeile in der Range
Dim r As Variant
' Array für Key u. Value
Dim x(1) As String
' Alle Zeilen in a1 : E16 durchlaufen
For Each r In rng.Rows
' Wert aus jew. Zeile und Spalte D
strValueD = r.Cells(1, lColumnValue).Value
' Nur die Zeilen verarbeiten, in denen Spalte 4 (D) nicht leer ist
If Not strValueD = "" Then
' Schlüssel aus Spalte 1(A) und 5 (E) bilden
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
' Schlüssel und Wert dem Array x zuweisen
x(0) = strKeyAE
x(1) = strValueD
' Array einer ArrayList ArrayList01 zuweisen
ArrayList01.Add x
End If
Next r
' Spaltenfortschritt
Dim c As Long
' Item d. ArrayListObjects
Dim j As Variant
' Werte bei jedem Key ausgeben (mit Dublikaten)
If blnDublikate = True Then
' Range nochmal durchlaufen
For Each r In rng.Rows
c = 0
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
For Each j In ArrayList01
If strKeyAE = j(0) Then
With r.Cells(1, lTargetColum)
If Not .Value = "" Then
' Abbruch wenn die letzte Zelle nich leer ist
If r.Cells(1, 16384) <> "" Then
MsgBox "Zelle " & r.Cells(1, 16384).Address & " ist nicht _
leer." & vbCrLf & _
"Die Verarbeitung wird abgebrochen", vbCritical + vbOKOnly, " _
Routine x-Files"
End
End If
With r.Cells(1, 16384).End(xlToLeft).Offset(0, 1)
.Value = j(1)
'.Interior.Color = rgbLime
End With
Else
With r.Cells(1, lTargetColum + c)
.Value = j(1)
'.Interior.Color = rgbLightGreen
End With
c = c + 1
End If
End With
End If
Next j
Next r
' Werte nur beim ersten Vorkommen ausgeben (ohne Dublikate)
' blnDublikate = False
Else
' ArrayList zum Merken der Verarbeiteten Schlüssel
Dim ArrayListOc As Object 'New ArrayList
Set ArrayListOc = CreateObject("system.collections.arraylist")
For Each r In rng.Rows
c = 0
strKeyAE = r.Cells(1, lColumnKey1).Value & r.Cells(1, lColumnKey2)
' Abgearbeiteten Schlüssel merken
With ArrayListOc
If Not .Contains(strKeyAE) Then
.Add strKeyAE
For Each j In ArrayList01
If strKeyAE = j(0) Then
With r.Cells(1, lTargetColum)
If Not .Value = "" Then
' Abbruch wenn die letzte Zelle nich leer ist
If r.Cells(1, 16384) <> "" Then
MsgBox "Zelle " & r.Cells(1, 16384).Address & " ist _
nicht leer." & vbCrLf & _
"Die Verarbeitung wird abgebrochen", vbCritical + _
vbOKOnly, "Abbruch in Routine x-Files"
End
End If
With r.Cells(1, 16384).End(xlToLeft).Offset(0, 1)
.Value = j(1)
'.Interior.Color = rgbLime
End With
Else
With r.Cells(1, lTargetColum + c)
.Value = j(1)
'.Interior.Color = rgbLightGreen
End With
c = c + 1
End If
End With
End If
Next j
End If
End With
Next r
End If
End With
End Sub
Achtung: Nach dem Kopieren in ein Modul, noch die von der Forumssoftware eingefügten Umbrüche.Cells(1, lColumnValue .EntireColumn.ClearContents
sollte dann da unten so aussehen:
End If
' Inhalt in Spalte 4 (D) löschen
.Cells(1, lColumnValue .EntireColumn.ClearContents
End With
End Sub
Mit den Duplikaten entfernen. Musst du nochmal genauer erläutern!Sub Makro1()
' Makro1 Makro
Range("A1:II15282").Select
Range("D15213").Activate
ActiveSheet.Range("$A$1:$II$15282").RemoveDuplicates Columns:=Array(1, 5), _
Header:=xlNo
End Sub
Aber ich habe mich doch entschieden, dich entscheiden zu lassen, wieviel Arbeit das ist, das mit dem Sortieren umzusetzen.Private Sub Worksheet_Change(ByVal Target As Range)
Dim TC As Long
Dim c As Range
Application.ScreenUpdating = False
If Target.Columns.Count > 1 Then Exit Sub
If Target.Column = 5 Or Target.Column = 7 Then TC = Target.Column Else Exit Sub
'If Target.Count = 1 And Target <> "" Then
On Error GoTo ERREXIT
Application.EnableEvents = False
Select Case TC
Case 5: For Each c In Target
If c <> "" Then Call SpalteE(c)
Next
Case 7: For Each c In Target
If c <> "" Then
Call SpalteG(c)
Call SpalteE(c)
End If
Next
End Select
ERREXIT:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub SpalteG(ByVal Target As Range)
Dim r As Range, c As Range, z&, cc As Range, zf&
Dim gefunden As Boolean
If Target.Offset(, -6) <> "" Then
z = Target.Row
gefunden = False
Set cc = Range("A1:A" & z - 1).Find(Target.Offset(, -6).Value, _
Range("A1"), xlValues, xlWhole)
If Not cc Is Nothing Then
zf = cc.Row
Do
Set cc = Range("A1:A" & z - 1).FindNext(cc)
If cc.Offset(, 6) = Target Then
Target.Offset(, -2) = cc.Offset(, 4) '& " " & (cc.Offset(, 4).Address)
gefunden = True
End If
Loop Until cc Is Nothing Or cc.Row = zf Or gefunden
End If
If Not gefunden Then Target.Offset(, -2).Value = "n.v."
End If
End Sub
Sub SpalteE(ByVal Target As Range)
Dim lngR As Long
lngR = Target.Row
Cells(lngR, 2).FormulaR1C1 = Cells(1, 2).FormulaR1C1
Cells(lngR, 3).FormulaR1C1 = Cells(1, 3).FormulaR1C1
Cells(lngR, 6).FormulaR1C1 = Cells(1, 6).FormulaR1C1
Cells(lngR, 8).FormulaR1C1 = Cells(1, 8).FormulaR1C1
Cells(lngR, 9).FormulaR1C1 = Cells(1, 9).FormulaR1C1
Cells(lngR, 10).FormulaR1C1 = Cells(1, 10).FormulaR1C1
Cells(lngR, 11).FormulaR1C1 = Cells(1, 11).FormulaR1C1
Cells(lngR, 12).FormulaR1C1 = Cells(1, 12).FormulaR1C1
Rows(lngR).Copy
Cells(lngR, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Target.Select
End Sub
Sub Makro1()
' Makro1 Makro
Range("A1:II15282").Select
Range("D15213").Activate
ActiveSheet.Range("$A$1:$II$15282").RemoveDuplicates Columns:=Array(1, 5), _
Header:=xlNo
End Sub
Aber ich habe mich doch entschieden, dich entscheiden zu lassen, wieviel Arbeit das ist, das mit dem Sortieren umzusetzen.Private Sub Worksheet_Change(ByVal Target As Range)
Dim TC As Long
Dim c As Range
Application.ScreenUpdating = False
If Target.Columns.Count > 1 Then Exit Sub
If Target.Column = 5 Or Target.Column = 7 Then TC = Target.Column Else Exit Sub
'If Target.Count = 1 And Target <> "" Then
On Error GoTo ERREXIT
Application.EnableEvents = False
Select Case TC
Case 5: For Each c In Target
If c <> "" Then Call SpalteE(c)
Next
Case 7: For Each c In Target
If c <> "" Then
Call SpalteG(c)
Call SpalteE(c)
End If
Next
End Select
ERREXIT:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub SpalteG(ByVal Target As Range)
Dim r As Range, c As Range, z&, cc As Range, zf&
Dim gefunden As Boolean
If Target.Offset(, -6) <> "" Then
z = Target.Row
gefunden = False
Set cc = Range("A1:A" & z - 1).Find(Target.Offset(, -6).Value, _
Range("A1"), xlValues, xlWhole)
If Not cc Is Nothing Then
zf = cc.Row
Do
Set cc = Range("A1:A" & z - 1).FindNext(cc)
If cc.Offset(, 6) = Target Then
Target.Offset(, -2) = cc.Offset(, 4) '& " " & (cc.Offset(, 4).Address)
gefunden = True
End If
Loop Until cc Is Nothing Or cc.Row = zf Or gefunden
End If
If Not gefunden Then Target.Offset(, -2).Value = "n.v."
End If
End Sub
Sub SpalteE(ByVal Target As Range)
Dim lngR As Long
lngR = Target.Row
Cells(lngR, 2).FormulaR1C1 = Cells(1, 2).FormulaR1C1
Cells(lngR, 3).FormulaR1C1 = Cells(1, 3).FormulaR1C1
Cells(lngR, 6).FormulaR1C1 = Cells(1, 6).FormulaR1C1
Cells(lngR, 8).FormulaR1C1 = Cells(1, 8).FormulaR1C1
Cells(lngR, 9).FormulaR1C1 = Cells(1, 9).FormulaR1C1
Cells(lngR, 10).FormulaR1C1 = Cells(1, 10).FormulaR1C1
Cells(lngR, 11).FormulaR1C1 = Cells(1, 11).FormulaR1C1
Cells(lngR, 12).FormulaR1C1 = Cells(1, 12).FormulaR1C1
Rows(lngR).Copy
Cells(lngR, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Target.Select
End Sub
.Cells(1, lColumnValue).EntireColumn.ClearContents
Application.OnTime Now + TimeValue("00:00:02"), "Makro5"
Application.OnTime Now + TimeValue("00:00:15"), "Makro3"
Application.Wait (Now + TimeValue("0:00:02"))
Möglicherweise musst Du die Pausen (in Sekunden) heraufsetzen.