AW: Spezifische Feldkombinationen auflisten lassen
10.01.2020 10:59:12
Werner
Hallo Martin,
teste mal:
Option Explicit
Sub MachMal_2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rg1 As Range, rg2 As Range, rg3 As Range
Dim s1 As String, s2 As String, s3 As String, i As Long
Dim loLetzte As Long
Set ws1 = ThisWorkbook.Worksheets("Modelle")
Set ws2 = ThisWorkbook.Worksheets("CSV_2")
ws2.Cells.Clear
With ws1
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If s3 = vbNullString Then
s3 = .Cells(i, "A")
Else
s3 = s3 & ";" & .Cells(i, "A")
End If
Next i
If Not s3 = vbNullString Then
ws2.Range("A1") = s3
End If
s3 = ""
'Variante 1 und Variante 2 in Spalte O kopieren
.Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Copy
.Range("O1").PasteSpecial Paste:=xlPasteValues
.Range("E2:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Copy
.Range("O" & .Cells(.Rows.Count, "O").End(xlUp).Offset(1).Row).PasteSpecial _
Paste:=xlPasteValues
'Varianten in Spalte O sortieren
loLetzte = .Cells(.Rows.Count, "O").End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("O1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With .Sort
.SetRange Range("O1:O" & loLetzte)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Application.CutCopyMode = False
'Duplikate in Spalte O entfernen
.Columns("O:O").RemoveDuplicates Columns:=1, Header:=xlNo
'Daten in Spalte O verketten
For i = 1 To .Cells(.Rows.Count, "O").End(xlUp).Row
If s3 = vbNullString Then
s3 = .Cells(i, "O")
Else
s3 = s3 & ";" & .Cells(i, "O")
End If
Next i
If Not s3 = vbNullString Then
ws2.Range("A2") = s3
End If
'Spalte O leeren
.Columns("O").ClearContents
End With
Set rg1 = ws1.Range("A2")
Set rg2 = ws2.Range("A4")
Do While rg1.Value ""
'Variante 1 - einzeln
s1 = "": s2 = ""
s1 = "Artikel=" & rg1.Value & "|Variante=" & rg1.Offset(0, 1).Value & _
"|Einzeln oder paarweise=einzeln"
rg2.Value = s1: rg2.Offset(0, 1).Value = rg1.Offset(0, 2).Value
'Variante 1 - paar
Set rg2 = rg2.Offset(1, 0)
s1 = "Artikel=" & rg1.Value & "|Variante=" & rg1.Offset(0, 1).Value & _
"|Einzeln oder paarweise=paarweise"
rg2.Value = s1: rg2.Offset(0, 1).Value = rg1.Offset(0, 3).Value
If rg1.Offset(0, 4).Value "" Then
'Variante 2 - einzeln
Set rg2 = rg2.Offset(1, 0)
s1 = "Artikel=" & rg1.Value & "|Variante=" & rg1.Offset(0, 4).Value & _
"|Einzeln oder paarweise=einzeln"
rg2.Value = s1: rg2.Offset(0, 1).Value = rg1.Offset(0, 5).Value
'Variante 2 - paar
Set rg2 = rg2.Offset(1, 0)
s1 = "Artikel=" & rg1.Value & "|Variante=" & rg1.Offset(0, 4).Value & _
"|Einzeln oder paarweise=paarweise"
rg2.Value = s1: rg2.Offset(0, 1).Value = rg1.Offset(0, 6).Value
End If
Set rg1 = rg1.Offset(1, 0)
Set rg2 = rg2.Offset(1, 0)
Loop
Set rg1 = Nothing: Set rg2 = Nothing
Set ws1 = Nothing: Set ws2 = Nothing
End Sub
Gruß Werner