Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1576to1580
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Ergnzen

Ergnzen
31.08.2017 10:12:40
Kurt
Guten Morgen,
anbei ein Muster.
Ich möchte gern das fehlende Produkt einsetzen.
Angefangen in F4 und G4 nach unten.
Links werden die Produkte B4 bis E200 eingesetzt.
https://www.herber.de/bbs/user/115907.xlsx
mfg
kurt k

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Meinst Du so...
31.08.2017 13:35:37
Michael
Kurt,
...Bsp-Datei: https://www.herber.de/bbs/user/115913.xlsm
Zum Testen die Schaltfläche anklicken.
Als Code:
Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.Worksheets("Tabelle1")
Dim a, b, d As Object, i&, j&, k&, l&
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
With Ws
a = .Range("B3:G3")
b = .Range("B4:G" & .Cells(.Rows.Count, "B").End(xlUp).Row)
For i = LBound(b) To UBound(b)
For j = LBound(b, 2) To UBound(b, 2) - 2
d.Add b(i, j), ""
Next j
For k = LBound(a, 2) To UBound(a, 2)
If Not d.exists(a(1, k)) Then
l = l + 1
b(i, 4 + l) = a(1, k)
End If
Next k
d.RemoveAll: l = 0
Next i
.Range("B4:G" & .Cells(.Rows.Count, "B").End(xlUp).Row) = b
End With
Set Wb = Nothing: Set Ws = Nothing
Erase a: Erase b: Set d = Nothing
End Sub
LG
Michael
Anzeige
Danke Michael, genau so --)
31.08.2017 14:59:17
Kurt
Na super, dann Danke für die Rückmeldung, owT
31.08.2017 15:09:19
Michael
Michael, Bitte nochmal helfen
31.08.2017 16:52:20
Kurt
Hallo Michael,
bitte nochmal helfen, danke im Voraus.
Ich wollte die Daten jetzt von D15:i15
und natürlich von D16:i & ...
leider klappt es nicht, warum auch immer.
Sub ergänzen()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.Worksheets("ergänzen")
Dim a, b, d As Object, i&, j&, k&, l&
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
With Ws
a = .Range("D15:i15")
b = .Range("D16:i" & .Cells(.Rows.Count, "d").End(xlUp).Row)
For i = LBound(b) To UBound(b)
For j = LBound(b, 2) To UBound(b, 2) - 2
d.Add b(i, j), ""
Next j
For k = LBound(a, 2) To UBound(a, 2)
' If Not d.exists(a(1, k)) Then
' l = l + 1
' b(i, 4 + l) = a(1, k)
' End If
Next k
d.RemoveAll: l = 0
Next i
.Range("D16:i" & .Cells(.Rows.Count, "d").End(xlUp).Row) = d
End With
Set Wb = Nothing: Set Ws = Nothing
Erase a: Erase b: Set d = Nothing
mfg
kurt k
Anzeige
Michael bei Dir klappts aber
31.08.2017 18:13:41
Kurt
Hallo Michael,
bei Dir klappts.
Bei mir bleibt Makro hier stehen:
d.Add b(i, j), ""
Hinweis: Dieser Schlüssel ist bereits einem Element dieser Auflistung zugeordnet
gruß
kurt k
Geht doch...
31.08.2017 18:18:19
Kurt
Michael es klappt doch.
Was muss ich ändern um die Überschriften D15:i15
2 Zeilen darüber zu plazieren.
Also D13:i13.
mfg
kurt k
Hab geändert alles funktioniert DANKE -)
31.08.2017 18:21:12
Kurt
Na bitte, Top! lg und owT
31.08.2017 19:36:33
Michael

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige