AW: VBA-Lösung gesucht
09.11.2017 14:13:37
Peter(silie)
Hallo,
hier deine Mappe mit Code: https://www.herber.de/bbs/user/117557.xlsm
(In Tabelle4 auf den Button "Hit Me" klicken)
Ich muss dir leider sagen, dass ich mich weigere Redundante Daten x-Tausend mal unter einander zu schreiben.
Bei dem Makro erhählst du den Text und die Anzahl an vorkommnissen.
Hier ist nur der Code:
Option Explicit
Public Sub Reorder_Values()
Dim worksheet_ As Worksheet
Dim tmp() As Variant
Dim dict1 As Object
Dim dict2 As Object
Dim t As String
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
Set worksheet_ = ThisWorkbook.Sheets(1)
tmp = Get_Array(worksheet_, 19)
Keys_from_Array tmp, dict1
Keys_from_Array tmp, dict2
Set worksheet_ = ThisWorkbook.Sheets(2)
tmp = Get_Array(worksheet_, 3)
Dim varItem
For Each varItem In dict1.Keys
Set dict1(varItem) = Counted_Items(tmp, varItem)
Next varItem
Erase tmp
Set worksheet_ = ThisWorkbook.Sheets(3)
tmp = Get_Array(worksheet_, 4)
For Each varItem In dict2.Keys
If dict2(varItem) Is Nothing Then Set dict2(varItem) = Counted_Items(tmp, varItem)
Next varItem
Erase tmp
Set worksheet_ = ThisWorkbook.Sheets(4)
Add_to_Sheet dict1, dict2, worksheet_
Set dict1 = Nothing
Set dict2 = Nothing
Set worksheet_ = Nothing
End Sub
Private Function Get_Array(ByRef ofWorksheet As Worksheet, ByVal ofColumn As Long) As Variant
With ofWorksheet
Dim rng As Range
Dim lRow As Long
lRow = .Cells(.Rows.Count, ofColumn).End(xlUp).Row
Set rng = .Range(.Cells(2, ofColumn), .Cells(lRow, ofColumn))
Get_Array = rng.Value2: Set rng = Nothing
End With
End Function
Private Sub Keys_from_Array(ByRef source() As Variant, ByRef This_Dictionary As Object)
Dim varItem As Variant
For Each varItem In source
If varItem "" And Not This_Dictionary.Exists(varItem) Then This_Dictionary.Add _
varItem, Nothing
Next varItem
End Sub
Private Function Contains(ByVal This_String As String, That_ As String) As Boolean
If InStr(1, This_String, That_, vbTextCompare) > 0 Then Contains = True
End Function
Private Function Counted_Items(ByRef source() As Variant, ByVal must_contain As String) As _
Object
Dim dict As Object
Dim varItem As Variant
Set dict = CreateObject("Scripting.Dictionary")
For Each varItem In source
If Contains(varItem, must_contain) Then
If Not dict.Exists(varItem) Then
dict.Add varItem, 1
Else
Dim i As Long
i = dict(varItem)
i = i + 1
dict(varItem) = i
End If
End If
Next varItem
Set Counted_Items = dict
Set dict = Nothing
End Function
Private Sub Add_to_Sheet(ByRef dict1 As Object, ByRef dict2 As Object, ByRef Sheet_ As _
Worksheet)
Dim varItem As Variant, varItem2 As Variant
Dim lRow As Long, i As Long
Dim tmp1 As Object
Dim tmp2 As Object
Dim rng As Range
With Sheet_
For Each varItem In dict1.Keys
Set tmp1 = dict1(varItem)
Set tmp2 = dict2(varItem)
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row
If lRow