VBA Grafiken selektieren und kopieren

Hallo und guten Abend.
Mein Name ist Stefan und ich bin neu hier in Forum.
Eigentlich dachte ich, dass ich mich gut mit Excel auskenne, wenn ich aber hier in Forum lese, merke ich, dass ich gegen Euch noch ein blutiger Anfänger bin.
Deshalb habe ich auch die Hoffnung, dass die Lösung meines Problems eine leichte Aufgabe für jemanden von Euch ist.
Ich habe zur Vereinfachung und zur besseren Beschreibung meines Problems eine kleine Beispieldatei gebastelt,
die ich hier einfüge.
https://www.herber.de/bbs/user/148660.xlsx
Die Beschreibung:
Im Worksheet "Quelle" sind in Spalte "A" Grafiken und in Spalte "B" Namen, in "C" Uhrzeit und in "D" Temperatur.
Nun soll mit VBS eine neues Worksheet "ZIEL" angelegt werden und die Werte aus Worksheet "Quelle" in einer anderen Form übernommen werden.
Die Spaltenbezeichnungen sollen nun
A = Bilder
B = Name
C, D, E, F, G = die Zeiten aus spalte "Uhrzeit" sein.
So weit, so gut. Das bekomme ich hin.
Nun zu meinem Problem und der gesuchten Lösung:
Der "Name" aus Quelle!B2 muss nach Ziel!B2 kopiert werden. Die dazugehörige Grafik (Sonne) aus Quelle!A2 dann nach Ziel!A2.
Jetzt Name Quelle!B3 auslesen und prüfen, ob in Ziel!Bn schon existiert. (Sonne).
Dann weiter Quelle!B4 auslesen ...
Wenn "Sonne" schon existiert, überspringen, bis neuer Name (Wolke) gefunden wird.
Dann Name (Wolke) aus Quelle!B7 nach nächste freie Zelle, Ziel!B3 kopieren und dazu gehörige Grafik aus Quelle!A7 nach Ziel!A3.
Es darf jeder "Name" und jede "Grafik" im Worksheet "Ziel" nur einmal vorkommen.
Ich danke jetzt schon für Eure Hilfe
Viele Grüße, Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Lösungsvorschlag

18.10.2021 10:39:51

Beverly

AW: Lösungsvorschlag

18.10.2021 11:42:38

Stiefelchen

Erläuterung

18.10.2021 12:30:33

Beverly

AW: Erläuterung

18.10.2021 12:46:34

Stiefelchen

Sub Kopieren() Dim lngZeile As Long Dim lngZeile2 As Long Dim lngZiel As Long Dim lngAnzahl As Long Dim shaShape As Shape Dim varSpalte lngZiel = 2 For lngZeile = 2 To IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count) lngAnzahl = Application.CountIf(Columns(2), Cells(lngZeile, 2)) With Worksheets("Ziel") .Cells(lngZiel, 2) = Cells(lngZeile, 2) For lngZeile2 = lngZeile To lngZeile + lngAnzahl - 1 Set varSpalte = .Rows(1).Find(CDate(Cells(lngZeile2, 3)), lookat:=xlWhole, LookIn:=xlFormulas) .Cells(lngZiel, varSpalte.Column) = Cells(lngZeile2, 4) Next lngZeile2 For Each shaShape In ActiveSheet.Shapes If shaShape.TopLeftCell.Address = Cells(lngZeile, 1).Address Then shaShape.CopyPicture .Cells(1, 1).PasteSpecial .Shapes(.Shapes.Count).Top = .Cells(lngZiel, 1).Top .Shapes(.Shapes.Count).Left = .Cells(lngZiel, 1).Left Exit For End If Next shaShape End With lngZiel = lngZiel + 1 lngZeile = lngZeile + lngAnzahl - 1 Next lngZeile End Sub

Hi Stefan,
ich habe den Code mit einigen Kommentaren versehen die dir helfen sollen, ihn besser zu verstehen. Wenn du trotzdem noch Fragen hast - einfach rückfragen.


Sub Kopieren()
Dim lngZeile As Long        ' Variable für laufende Zeile
Dim lngZeile2 As Long      ' Variable für laufende Zeile innere Schleife
Dim lngZiel As Long          ' Variable für Zielzeile
Dim lngAnzahl As Long     ' Variable für Anzahl des jeweiligen begriffs aus Spalte B
Dim shaShape As Shape  ' Variable für laufendes Shape
Dim varSpalte                   ' Variable für Suche der Uhrzeit Spalte C in Zieltabelle Zeile 1
lngZiel = 2
' Schleife von Zeile 2 bis letzte belegte Zeile in Spalte B der aktiven Tabelle
For lngZeile = 2 To IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
' Anzahl an Begriffen der laufenden Zeile in Spalte B
lngAnzahl = Application.CountIf(Columns(2), Cells(lngZeile, 2))
' bezogen auf Tabelle "Ziel"
With Worksheets("Ziel")
' Spalte B Zielzeile = laufende Zelle Spalte B Ausgangstabelle
.Cells(lngZiel, 2) = Cells(lngZeile, 2)
' Schleife über die Anzahl des laufenden Begriffs (Name) in Spalte B
For lngZeile2 = lngZeile To lngZeile + lngAnzahl - 1
' suche die laufende Uhrzeit aus Spalte C in Zeile 1 Tabelle "Ziel"
Set varSpalte = .Rows(1).Find(CDate(Cells(lngZeile2, 3)), lookat:=xlWhole, LookIn:=xlFormulas)
' Zelle laufende Zielzeile in gefundener Spalte = Temperatur aus laufende Zeile Spalte D Ausgangstabelle
.Cells(lngZiel, varSpalte.Column) = Cells(lngZeile2, 4)
Next lngZeile2
' Schleife über alle Shapes
For Each shaShape In ActiveSheet.Shapes
' Adresse linke obere Ecke des laufnden Shapes = Adresse Zelle laufende Zeile Spalte A
If shaShape.TopLeftCell.Address = Cells(lngZeile, 1).Address Then
' kopiere das Shape
shaShape.CopyPicture
' in Zieltabelle einfügen
.Cells(1, 1).PasteSpecial
' Zellposition des eingefügten Shapes festlegen
.Shapes(.Shapes.Count).Top = .Cells(lngZiel, 1).Top
.Shapes(.Shapes.Count).Left = .Cells(lngZiel, 1).Left
Exit For
End If
Next shaShape
End With
' Zielzeile um 1 erhöhen
lngZiel = lngZiel + 1
' laufende Zeile erhöhen um Anzahl an Begriffen - 1 für nächsten Schleifendurchlauf
lngZeile = lngZeile + lngAnzahl - 1
Next lngZeile
End Sub

Noch ein Hinweis: es wird vorausgesetzt, dass alle Uhrzeiten aus der Ausgangstabelle in Zeile 1 der Zieltabelle aufgeführt sind.

Beliebteste Forumthreads (12 Monate)

VBA Grafiken selektieren und kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread