AW: richtig kopieren nach Kriterien
10.02.2019 13:50:22
Sepp
Hallo Fred,
Sub DatenNach_Spiele()
Dim varFilter() As Variant, varItems As Variant
Dim lngI As Long, lngN As Long, lngM As Long, lngLast As Long
With Sheets("Spiele")
.Range("A2:J" & .Rows.Count).ClearContents
.Range("K3:AL" & .Rows.Count).ClearContents
End With
With Sheets("Kriterien")
lngLast = .Cells(1, .Columns.Count).End(xlToLeft).Column
Redim varFilter(1 To lngLast)
lngN = lngLast
For lngI = 1 To lngN
If Application.CountA(.Columns(lngI)) > 1 Then
lngLast = Application.Max(2, .Cells(.Rows.Count, lngI).End(xlUp).Row)
varItems = Application.Transpose(.Range(.Cells(2, lngI), .Cells(lngLast, lngI)))
If IsArray(varItems) Then
For lngM = 1 To Ubound(varItems)
varItems(lngM) = CStr(varItems(lngM))
Next
Else
varItems = CStr(varItems)
End If
varFilter(lngI) = varItems
End If
Next
End With
With Sheets("Basis")
With .Range("A1").CurrentRegion
.AutoFilter
For lngI = 1 To Ubound(varFilter)
If Not IsEmpty(varFilter(lngI)) Then
.AutoFilter Field:=lngI, Criteria1:=varFilter(lngI), Operator:=xlFilterValues
End If
Next
.SpecialCells(xlCellTypeVisible).Copy Sheets("Spiele").Range("A1")
.AutoFilter
End With
End With
With Sheets("Spiele")
lngLast = Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row)
.Range("K2:AL2").AutoFill .Range("K2:AL" & lngLast)
Application.Goto .Range("A1"), True
End With
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0