Microsoft Excel

Herbers Excel/VBA-Archiv

Bereich beschränken zur Bildsuche


Betrifft: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 29.11.2018 16:34:34

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

  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Rudi Maintaire
Geschrieben am: 29.11.2018 16:45:50

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


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 29.11.2018 16:51:15

Hallo Rudi Maintaire

Ja Danke das funktioniert prima
Grüße


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 29.11.2018 17:56:32

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


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Daniel
Geschrieben am: 29.11.2018 18:07:17

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


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 29.11.2018 18:17:11

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


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Werner
Geschrieben am: 29.11.2018 18:20:17

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


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 29.11.2018 18:40:23

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


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Werner
Geschrieben am: 29.11.2018 19:52:14

Hallo Fred,

und in welcher Codezeilte, bei mir nämlich nicht.

Gruß Werner


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 29.11.2018 20:09:32

Hallo Werner
Diese Zeile ist markiert.

  If Not Intersect(Picture.TopLeftCell, Range("A4:F8")) Is Nothing Then
Grüße Fred


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Daniel
Geschrieben am: 29.11.2018 21:08:57

Hi

probier mal

If Picture.TopLeftCell.row >= 4 And Picture.TopLeftCell.row <= 8 And Picture.TopLeftCell.Column <= 6  Then

gruß Daniel


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 29.11.2018 21:34:14

Hallo Daniel

Danke für Deine Antwort. Leider meckert der Debugger dann bei

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

Grüße Fred


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Daniel
Geschrieben am: 29.11.2018 21:53:58

lad mal ne Beispieldatei hoch.
die sollte, nebeb ein paar Bildern, dein erstes Makro und dein aktuelles Makro enthalten.

gruß Daniel


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 29.11.2018 22:37:30

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.

http://www.herber.de/bbs/user/125774.zip

Grüße Fred


  

Betrifft: AW: Bereich beschränken zur Bildsuche
von: Fred
Geschrieben am: 30.11.2018 22:25:47

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