Spalte leer
Klaus
habe von Forummitglied Franz eine super Lösung bekommen und nun festgestellt, dass noch eine Erweiterung eingebaut werden müsste.
Der Filter wird in Spalte 7 gesetzt und dann die gefilterten Werte aus Spalte 14 kopiert.
Jetzt kommt es aber vor, dass in Spalte 14 keine Werte gefunden wurden. In dem Fall sollen die Werte aus Spalte 15 kopiert werden.Da ich blutiger VBA-Anfänger bin und eigentlich nur mit dem Makrorecorder kann, bin ich auf eure Hilfe angewiesen.
Schon mal vielen Dank für eure Unterstützung.
Sub aaaTest()
Dim WksSpieler As Worksheet, wksZiel As Worksheet, Zeile As Long
Dim oCollection As New Collection, iI As Long
Set WksSpieler = Sheets("Rechnungspositionen")
Set wksZiel = Sheets("Tabelle1")
On Error GoTo Fehler
ActiveCell.Offset(1, 0).Range("A1").Select
With WksSpieler
.Activate
Application.ScreenUpdating = True
If .FilterMode = True Then ActiveSheet.ShowAllData 'Einblenden aller Datenzeilen
'Alle verschiedenen sichtbaren Werte in Spalte 7 ab Zeile 2 einmal erfassen
For Zeile = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row
If .Cells(Zeile, 7).EntireRow.Hidden = False Then
oCollection.Add Item:=.Cells(Zeile, 7).Value, Key:=.Cells(Zeile, 7).Text
End If
Next
'Filterwerte setzen und gefundene Daten kopieren
For iI = 1 To oCollection.Count
'Filter in Spalte 7 setzen
.Range("$A$1:$R$8611").AutoFilter Field:=7, Criteria1:= _
oCollection.Item(iI)
If .Cells(.Rows.Count, 7).End(xlUp).Row >= 2 Then
'gefilterte Werte in Spalte 14 kopieren
.Range(.Cells(2, 14), .Cells(.Rows.Count, 14).End(xlUp)).Copy
With wksZiel
'Werte + Formate in Spalte+1 ab Zeile 2 einfügen
With .Cells(2, Spalte + 1)
.PasteSpecial Paste:=xlFormats
.PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
'Nachste Einfüge-Spalte
Spalte = Spalte + 1
If Spalte >= .Columns.Count Then
MsgBox "Im Zieltabellenblatt können keine weiteren Daten eingefügt werden!"
End If
End With
End If
Next
End With
wksZiel.Activate
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 457 'Collection soll Item ein 2. MAl hinzugefügt werden
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, "Makro - Autofilter-Auswertung"
End Select
End With
Application.ScreenUpdating = True
End Sub