Mehrere Bezüge zu Wert + mehrerer Spalten copy
28.08.2018 13:15:23
Arnd-Olav
anbie meine Beispielmappe.
Mit dem Makro hat mir ein Kollege hier bereits TOP geholfen, ich komme nur mit dem Rest nicht weiter.
Die Mappe hat drei Sheets. Vom Sheet "Input" sollen die PNs ausgelesen werden und mit den entsprechenden CC Codes aus dem Sheet "AQPL" auf das Sheet "Mail" gepackt werden.
In der angehangenen Datei funktioniert bisher alles, was auf dem Sheet "Mail" grün ist. Das was blau ist, macht das Makro noch nicht.
Es gibt also noch das Problem, dass PNs doppelt vorkommen. Dafür müsste dieses Autofilter-Makro ggf Zeile für Zeile ausgeführt werden ?!
Und dann möchte ich die zusätzlcihen Spalten aus dem Sheet "Input" auch mit kopiert haben (QTY, UOM, ORDER, Condition, CAT und Date, die jetzt ebenfalls noch blau markiert sind)
Danke euch
https://www.herber.de/bbs/user/123583.xlsm
Public Sub V1()
Dim FilterArray As Variant
Dim loLetzte As Long, loLetzte1 As Long, i As Long
Application.ScreenUpdating = False
With Worksheets("Input")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
If loLetzte = 1 Then
MsgBox "Es gibt keine Suchbegriffe"
Exit Sub
End If
For i = 2 To loLetzte
If .Cells(i, 1) "" Then
If FilterArray = "" Then
FilterArray = .Cells(i, 1)
Else
FilterArray = FilterArray & "," & .Cells(i, 1)
End If
End If
Next i
End With
With Worksheets("AQPL")
loLetzte1 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("$A$1:$C$" & loLetzte1).AutoFilter Field:=1, _
Criteria1:=Split(FilterArray, ","), Operator:=xlFilterValues
If .Cells(.Rows.Count, 1).End(xlUp).Row > 1 Then
With .AutoFilter.Range
.Resize(.Rows.Count - 1).Offset(1, 0).Copy _
Worksheets("Mail").Cells(2, 1)
End With
Else
MsgBox "Kein Treffer im Blatt ""AQPL"""
End If
If .AutoFilterMode Then .AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub