AW: Verschiede Texte finden und Werte in Zelle schreib
03.11.2017 09:18:41
Peter(silie)
Hallo,
hier deine Mappe mit anderen Code: https://www.herber.de/bbs/user/117411.xlsm
(Button in Nebenkosten Tabelle)
Hier nur Code:
Option Explicit
Private Rechnung As Worksheet
Private Nebenkosten As Worksheet
Public Sub ReOrder()
Dim varKey As Variant, varItem As Variant
Dim lRow As Long, lCol As Long, i As Long
Dim tmp_1() As String, tmp_2() As String
Dim dict As Dictionary
Dim rng As Range
Set Rechnung = ThisWorkbook.Sheets("Rechnung")
Set Nebenkosten = ThisWorkbook.Sheets("Nebenkosten")
lRow = Last_Row(Rechnung, 1)
lCol = Last_Column(Rechnung)
With Rechnung
Set rng = .Range(.Cells(1, 1), .Cells(lRow, lCol))
End With
Set dict = Rechnungs_Dictionary(rng)
i = 2
lCol = Last_Column(Nebenkosten)
With Nebenkosten
Set rng = .Range(.Cells(1, 1), .Cells(1, lCol))
For Each varKey In dict.Keys
.Cells(i, 1).Value = varKey
tmp_1 = Split(dict(varKey), "\")
For Each varItem In tmp_1
If varItem vbNullString And Len(varItem) > 1 Then
tmp_2 = Split(varItem, ";")
lCol = Match_Key(tmp_2(0), rng)
If lCol > 0 Then .Cells(i, lCol).Value = CDbl(tmp_2(1))
Erase tmp_2
End If
Next varItem
i = i + 1
Erase tmp_1
Next varKey
End With
Set dict = Nothing
Set Rechnung = Nothing
Set Nebenkosten = Nothing
End Sub
Private Function Rechnungs_Dictionary(ByRef rng As Range) As Dictionary
Dim key_ As String, item_ As String
Dim lRow As Long, lCol As Long
Dim dict_1 As New Dictionary
For lRow = 2 To rng.Rows.Count
key_ = rng.Cells(lRow, 1).Value
dict_1.Add key_, vbNull
For lCol = 2 To rng.Columns.Count Step 2
If InStr(1, item_, key_, vbTextCompare) = 0 Then
item_ = item_ & rng.Cells(lRow, lCol).Value
item_ = item_ & ";" & rng.Cells(lRow, lCol + 1).Value & "\"
End If
Next lCol
If dict_1.Exists(key_) Then dict_1(key_) = item_
item_ = ""
Next lRow
Set Rechnungs_Dictionary = dict_1
Set dict_1 = Nothing
End Function
Private Function Last_Column(ByRef OfSheet As Worksheet) As Long
With OfSheet
Last_Column = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
End Function
Private Function Last_Row(ByRef OfSheet As Worksheet, ByVal OfColumn As Long) As Long
With OfSheet
Last_Row = .Cells(.Rows.Count, OfColumn).End(xlUp).Row
End With
End Function
Private Function Match_Key(ByVal key_ As Variant, rng As Range) As Long
With Application
If Not VBA.IsError(.Match(key_, rng, 0)) Then
Match_Key = .Match(key_, rng, 0)
End If
End With
End Function