Thema Datum  Von Nutzer Rating
Antwort
18.10.2017 10:18:23 Rigo
NotSolved
18.10.2017 16:21:51 Gast7777
NotSolved
19.10.2017 08:13:44 Rigo
NotSolved
19.10.2017 11:17:10 Gast7777
NotSolved
19.10.2017 14:27:54 Rigo
NotSolved
Blau Spalten zusammenführen
20.10.2017 05:27:18 fransi
Solved
20.10.2017 08:26:47 Rigo
NotSolved

Ansicht des Beitrags:
Von:
fransi
Datum:
20.10.2017 05:27:18
Views:
699
Rating: Antwort:
 Nein
Thema:
Spalten zusammenführen
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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
18.10.2017 10:18:23 Rigo
NotSolved
18.10.2017 16:21:51 Gast7777
NotSolved
19.10.2017 08:13:44 Rigo
NotSolved
19.10.2017 11:17:10 Gast7777
NotSolved
19.10.2017 14:27:54 Rigo
NotSolved
Blau Spalten zusammenführen
20.10.2017 05:27:18 fransi
Solved
20.10.2017 08:26:47 Rigo
NotSolved