Option
Explicit
Sub
v2_TabellenObjekteDupliakteEntfernen()
Dim
oLstAuft
As
ListObject
Dim
oLstAngb
As
ListObject
Dim
oLstErgb
As
ListObject
Dim
oLstColm
As
ListColumn
Dim
rngDby
As
Range
Dim
objMyDic
As
Object
Dim
V
As
Variant
Dim
arrS()
As
Variant
Dim
objRange
As
Range, objDataRange
As
Range
Dim
x
As
Long
Set
objMyDic = CreateObject(
"Scripting.Dictionary"
)
Set
oLstAuft = Sheets(
"Aufträge "
).ListObjects(
"Tabelle1"
)
Set
oLstAngb = Sheets(
"Angebote "
).ListObjects(
"Tabelle13"
)
Set
oLstErgb = Sheets(
"Ergebnis"
).ListObjects(
"Tabelle3"
)
Set
oLstColm = oLstAuft.ListColumns(
"Material"
)
For
Each
rngDby
In
oLstColm.DataBodyRange
V = rngDby.Value
objMyDic(V) = V
Next
rngDby
Set
oLstColm = oLstAngb.ListColumns(
"Material"
)
For
Each
rngDby
In
oLstColm.DataBodyRange
V = rngDby.Value
objMyDic(V) = V
Next
rngDby
With
oLstErgb
.DataBodyRange.Clear
.DataBodyRange.NumberFormat =
"0"
Set
objRange = .Range
Set
objRange = objRange.Resize(objMyDic.Count + 1, objRange.Columns.Count)
.Resize objRange
End
With
arrS = objMyDic.Items()
Set
oLstColm = oLstErgb.ListColumns(
"Spalte1"
)
oLstColm.DataBodyRange.Value = Application.Transpose(arrS)
End
Sub