Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 14:04:05
PDF per VBA ausgeben - Seitenskalierung
19.04.2024 13:58:02
Set Worksheet geht im O365 aber im Excel 2016 nicht
19.04.2024 13:49:38
Per Kopfdruck als pdf speichern und Mail erstellen
19.04.2024 12:58:59
Daten einfügen aus anderem Sheet
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1660to1664
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1660to1664
1660to1664
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Bereich beschränken zur Bildsuche

Bereich beschränken zur Bildsuche
29.11.2018 16:34:34
Fred
Hallo
Ich würde gerne mit folgendem Code Ein Bild in die Andere Arbeitsmappe kopieren. Was auch super geht. meine frage wäre jetz ob ich den Suchbereich von der ganzen tabelle auch nur einen bestimmten Bereich begrenzen kann. Der Bereich wäre im aktiven Sheet A4 bis F8

Sub Bilder_kopieren()
Dim Picture As Shape
'Bildschirmaktualisierung deaktivieren
Application.ScreenUpdating = False
'Schleife zum Ansprechen aller Shape-Objekt im aktiven Tabellenblatt
'Anzahl der Schleifendurchläufe richtet sich nach Anzahl vorhandener Shape-Objekte
'Dazu zählen auch Buttons oder Textfelder.
For Each Picture In ActiveSheet.Shapes
Picture.Select Replace:=False
'Abfrage Ende
'Nächsten Schleifendurchlauf starten
Next
Selection.Copy
'...und in Blatt "Doku" einfügen
Sheets("Doku").Range("B1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
Grüße Fred

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bereich beschränken zur Bildsuche
29.11.2018 16:45:50
Rudi
Hallo,
teste mal 
For Each Picture In ActiveSheet.Shapes
if not intersect(Picture.topleftcell,Range("A4:F8")) is nothing then
Picture.Select Replace:=False
end if
'Abfrage Ende
'Nächsten Schleifendurchlauf starten
Next

Gruß
Rudi
AW: Bereich beschränken zur Bildsuche
29.11.2018 16:51:15
Fred
Hallo Rudi Maintaire
Ja Danke das funktioniert prima
Grüße
AW: Bereich beschränken zur Bildsuche
29.11.2018 17:56:32
Fred
ich habe da noch eine Frage
Ich wollte die Bilder dann mit 

Range("B" & Cells(Rows.Count, 2).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues

in die Tabelle untereinander einfügen Aber leider packt er die Bilder trotzdem alle nur in B2.
Ist da irgend etwas falsch am Code oder kann mann bilder nicht untereinander einfügen.
Grüße Fred
Anzeige
AW: Bereich beschränken zur Bildsuche
29.11.2018 18:07:17
Daniel
Hi
das End(xlup) erkennt keine Bilder, sondern nur Zellinhalte wie Texte, Zahlen, Formeln.
wenn du die Bilder untereinander einfügen willst, musst du Top- und Height-Wert des zuletzt eingefügten Bildes addieren und den Wert in einer Variablen speichern.
dann positionierst du das nächste Bild nach dem Einfügen an dieser Stelle.
für das erste Bild musst du eine Vorgabe machen.
wenn sich die Postion der Bilder nach den Zellen richten sollen, müsstest du einen Zähler mitlaufen lassen und diesen in der Schleife hochzählen und darüber die Zielzelle berechnen.
Gruß Daniel
Gruß Daniel
Anzeige
AW: Bereich beschränken zur Bildsuche
29.11.2018 18:17:11
Fred
Hallo daniel
das mit dem Zähler hörrt sich gut an ,leider bin ich absoluter Leihe in VBA und kriege das alleine nicht auf die Reihe.
Grüße Fred
AW: Bereich beschränken zur Bildsuche
29.11.2018 18:20:17
Werner
Hallo Fred,
so: 
Sub Bilder_kopieren()
Dim Picture As Shape, i As Long
Application.ScreenUpdating = False
i = 2
For Each Picture In ActiveSheet.Shapes
If Not Intersect(Picture.TopLeftCell, Range("A4:F8")) Is Nothing Then
Picture.Select
Selection.Copy
Sheets("Doku").Range("B" & i).PasteSpecial Paste:=xlPasteValues
i = i + 1
End If
Next
Application.CutCopyMode = False
End Sub
Gruß Werner
Anzeige
AW: Bereich beschränken zur Bildsuche
29.11.2018 18:40:23
Fred
Hallo Werner
Vielen dank für Deine schnelle Antwort.
Leider kommt bei dem Code der Debugger und sagt " die Methode Intersect_global ist fehlgeschlagen).
Grüße Fred
AW: Bereich beschränken zur Bildsuche
29.11.2018 19:52:14
Werner
Hallo Fred,
und in welcher Codezeilte, bei mir nämlich nicht.
Gruß Werner
AW: Bereich beschränken zur Bildsuche
29.11.2018 20:09:32
Fred
Hallo Werner
Diese Zeile ist markiert. 

If Not Intersect(Picture.TopLeftCell, Range("A4:F8")) Is Nothing Then
Grüße Fred
AW: Bereich beschränken zur Bildsuche
29.11.2018 21:08:57
Daniel
Hi
probier mal
If Picture.TopLeftCell.row >= 4 And Picture.TopLeftCell.row

gruß Daniel
AW: Bereich beschränken zur Bildsuche
29.11.2018 21:34:14
Fred
Hallo Daniel
Danke für Deine Antwort. Leider meckert der Debugger dann bei 

Sheets("Doku").Range("B" & i).PasteSpecial Paste:=xlPasteValues

Grüße Fred
Anzeige
AW: Bereich beschränken zur Bildsuche
29.11.2018 21:53:58
Daniel
lad mal ne Beispieldatei hoch.
die sollte, nebeb ein paar Bildern, dein erstes Makro und dein aktuelles Makro enthalten.
gruß Daniel
AW: Bereich beschränken zur Bildsuche
29.11.2018 22:37:30
Fred
Hallo Daniel
Anbei mal eine Beispieldatei
Makro/ Bilder_kopieren_NR1 funktioniert sortiert die Bilder aber alle nur nach B1
Makro/ Bilder_kopieren_Werner funktioniert nicht wirklich das macht was es will und das Bild wird auch nicht richtig kopiert.
https://www.herber.de/bbs/user/125774.zip
Grüße Fred
AW: Bereich beschränken zur Bildsuche
30.11.2018 22:25:47
Fred
Hallo
Falls es jemanden Interessiert so habe ich es jetzt gelöst. Danke an alle die mich unterstützt haben.
Grüße Fred 

'Option Private Module
Option Explicit
' alle bILDERin der Tabelle untereinander sortieren und größe angleichen
Sub BILDERFormatierenAnordnen()
Dim Picture As Shape, i As Long
Dim intHoch As Integer, intAbstand As Integer
Dim wksDoku As Worksheet
Set wksDoku = ActiveSheet
On Error GoTo Hell
intHoch = 150
intAbstand = 10
' wksDoku = Codename der Tabelle
For i = 1 To wksDoku.shapes.Count
With wksDoku.shapes(i)
.Height = intHoch
.Width = 370
.Left = 10
.Top = intHoch * i - intHoch + intAbstand * i
End With
Next i
Exit Sub
Hell:
MsgBox "FehlerNr.: " & Err.Number & _
vbNewLine & vbNewLine & _
"Beschreibung: " & Err.Description, _
vbCritical, "Fehler"
Application.ScreenUpdating = True
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige