Option Explicit
Sub v1_TabellenObjekteDupliakteEntfernen()
Dim objDataRange As Range, rngDby As Range, rngLst As Range
Dim objMyDic As Object
Dim V As Variant
Dim arrS() As Variant
Set objMyDic = CreateObject("Scripting.Dictionary")
'der Nährwert von abschließenden Leerzeichen der Arbeitsblatt-Namen blieb mir verborgen
Set objDataRange = Sheets("Aufträge ").ListObjects("Tabelle1").ListColumns("Material").DataBodyRange
For Each rngDby In objDataRange
V = rngDby.Value
objMyDic(V) = V
Next rngDby
Set objDataRange = Sheets("Angebote ").ListObjects("Tabelle13").ListColumns("Material").DataBodyRange
For Each rngDby In objDataRange
V = rngDby.Value
objMyDic(V) = V
Next rngDby
arrS = objMyDic.Items()
'Und dann hau ich mit dem Hämmerchen
With Sheets("Ergebnis")
On Error Resume Next
With .ListObjects("Tabelle3")
Set rngLst = .Range.Cells(1)
.Delete
End With
If Err.Number <> 0 Then Set rngLst = .Range("A4")
On Error GoTo 0
Set rngLst = rngLst.Resize(UBound(arrS) + 1, 1)
With rngLst
.NumberFormat = "0"
.Value = Application.Transpose(arrS)
End With
.ListObjects.Add(xlSrcRange, Range(rngLst.Address), , xlNo).Name = "Tabelle3"
End With
'Ich übernehme keinerlei Gewähr für die Aktualität, Richtigkeit und Vollständigkeit,
'denn was interessiert mich der Schmäh', den ich vor 10 min. geschrieben habe.
'Hauptsache er war gut!
End Sub
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")
'der Nährwert von abschließenden Leerzeichen der Arbeitsblatt-Namen blieb mir verborgen
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
'ohne Schlachtung
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)
'Ich übernehme keinerlei Gewähr für die Aktualität, Richtigkeit und Vollständigkeit,
'denn was interessiert mich der Schmäh', den ich vor 10 min. geschrieben habe.
'Hauptsache er war gut!
End Sub
|