Hallo,
vielleicht hilft Dir ja dieser VBA-Code weiter?
Sub CopyData()
Dim sh As Worksheet, nwSh As Worksheet
Dim rng As Range, rngFlt As Range
Dim copied() As String
Dim strValue As String
Dim lRwInsert As Long
Set sh = ThisWorkbook.Worksheets("Quelle")
For Each rng In sh.UsedRange.Rows
If rng.Row > 1 Then
strValue = rng.Cells(1, 2).Value
If Not arrayValueExists(copied, strValue) Then
ReDim Preserve copied(myUBound(copied) + 1)
copied(myUBound(copied)) = strValue
Set nwSh = ThisWorkbook.Worksheets.Add()
nwSh.Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
nwSh.Name = strValue
nwSh.Cells(1, 1) = sh.Cells(1, 1)
nwSh.Cells(1, 2) = sh.Cells(1, 2)
' Filter Data
sh.AutoFilterMode = False
With sh.Range("A1:B1")
.AutoFilter
.AutoFilter field:=2, Criteria1:=strValue
lRwInsert = 2
For Each rngFlt In sh.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
If rngFlt.Cells(1, 1) <> "" Then
nwSh.Cells(lRwInsert, 1) = rngFlt.Cells(1, 1)
nwSh.Cells(lRwInsert, 2) = rngFlt.Cells(1, 2)
lRwInsert = lRwInsert + 1
End If
Next
End With
sh.AutoFilterMode = False
End If
End If
Next
End Sub
Function myUBound(arr() As String) As Long
On Error Resume Next
myUBound = -1
myUBound = UBound(arr)
If Not Err.Number = 0 Then
Err.Clear
End If
End Function
Function arrayValueExists(arr() As String, findValue As String) As Boolean
Dim lCnt As Long
arrayValueExists = False
For lCnt = 0 To myUBound(arr)
If arr(lCnt) = findValue Then
arrayValueExists = True
Exit For
End If
Next
End Function
Kurze Erläuterung:
Der Befehl "CopyData" durchläuft in der Tabelle "Quelle" alle Einträge ab der zweiten Zeile.
Das Array "copied" enthält alle bereits gefundenen Einträge, die bereits kopiert worden sind. Falls ein Neuer Eintrag gefunden wurde, wird eine neue Tabelle angelegt und die gefundenen Einträge unter verwendung von AutoFilter kopiert.
LG, BigBen
|