Makro automatisieren
25.12.2018 17:17:14
Richard
es wäre nett wenn mir jemand eine Unterstützung gibt.
Folgender Ablauf: in einer LstBox werden Daten angeklickt und auf ein Tabellenblatt geschrieben _ Code
Private Sub cmb_Auswahlkatallog_Click()
Dim wks As Worksheet
Dim lngI As Long
Dim lngZ As Long
Dim intS As Integer
Dim intI As Integer
Set wks = Worksheets("Katallog")
lngZ = 2
wks.Range("A2:M100" & wks.Range("A65536").End(xlUp).Row).ClearContents
With Me.ListBox1
For lngI = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(lngI) Then
intI = 0
For intS = 0 To 8 'Anzahl Spalte =9
Select Case intS
Case 0, 2, 4, 6, 7 '0=a,1=B usw
intI = intI + 1
wks.Cells(lngZ, intI) = .List(lngI, intS)
Case Else
End Select
Next
lngZ = lngZ + 1
End If
Next
End With
End Sub
bei wechsel auf den Sheet werden die daten angezeigt Code
Private Sub cmdBeenden_Click()
Erase arrList, arrData
Set wksData = Nothing
Unload Me
Sheets("Katallog").Select
End Sub
Dies funktioniert einwandfrei ich möchte jedoch die nachfolgenden Makros (stehen im Sheet automatisch bei Wechsel ablaufen lassen d.h. Bilder einfügen und Rahmen setzen, beim Verlassen Bilder löschen und Rahmen entfernen.
mit Button geht dies alles einwandfrei
Diese Makros sollen automatisch ablaufen
Sub Bilder_einfügen_2()
Dim Pfad As String
Dim strDatnam As String
Dim Wiederholungen As Long
Dim Bildbreite As Single
Dim Bildhöhe As Single
Dim meinBild
Dim maxSpaltenbreite As Single
Dim Bild As Shape
Dim Zelle As Range
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Pfad angeben
Pfad = "C:\Bildeinfügen\ArtNr\"
'Spalte A ab Zeile 2 durchlaufen
For Wiederholungen = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Namen der Bilder stehen in Spalte 4 - ohne Endung; Einlesen in Variable mit Pfadangaben
strDatnam = Pfad & Cells(Wiederholungen, 4).Value & ".jpg"
'Prüfen, ob Bilddatei im Verzeichnis existiert
If Dir(strDatnam) "" Then
'falls ja, dann Bildhöhe und -breite einlesen
Set meinBild = LoadPicture(strDatnam)
Bildbreite = meinBild.Width
Bildhöhe = meinBild.Height
'Bild einfügen, 9 cm hoch - 1 cm = 28,35 pt - und Breite entsprechend skaliert
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 6).Left, _
Cells(Wiederholungen, 6).Top, 100 * Bildbreite / Bildhöhe, 100
'maximale Spaltenbreite ermitteln, für die Anpassung der Spaltenbreite
If maxSpaltenbreite Bildbreite / Bildhöhe
Else
'falls nein, wird in Spalte F eine Fehlermeldung geschrieben
ActiveSheet.Cells(Wiederholungen, 6) = "Bild nicht gefunden-nicht angelegt"
End If
Next
'Zeilenhöhe anpassen
Rows("2:" & ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row).RowHeight = 105
'Spaltenbreite anpassen
Columns("F:F").ColumnWidth = (WorksheetFunction.RoundUp(maxSpaltenbreite / 5, 0) + 2)
'Alle Bilder im Blatt in Zelle zentrieren
For Each Bild In ActiveSheet.Shapes
With Bild.TopLeftCell
Set Zelle = Cells(.Row, .Column)
End With
Bild.Top = Zelle.Top + (Zelle.Height - Bild.Height) / 2
Bild.Left = Zelle.Left + (Zelle.Width - Bild.Width) / 2
Next
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Sub Bilderloeschen_Click()
Const cBereich = "F2:F10"
Dim shp As Object
For Each shp In Tabelle5.Shapes
If Not Intersect(Tabelle5.Range(cBereich), shp.TopLeftCell) Is Nothing Then shp.Delete
Next shp
Range("F2:F10").ClearContents
End Sub
Private Sub cmbRahmenentfernen_Click()
Dim rBereich As Range
Dim rZelle As Range
' ThisWorkbook.Worksheets("Tabelle5").Activate
Set rBereich = Range("A2:F10")
Application.ScreenUpdating = False
For Each rZelle In rBereich
If Trim$(rZelle) "" Then
rZelle.Borders.LineStyle = xlNone ' alle Linien löschen
End If
Next rZelle
End Sub
Sub Rahmenerstellen_Click()
'Sub Rahmen_erstellen()
Dim rBereich As Range
Dim rZelle As Range
' ThisWorkbook.Worksheets("Tabelle5").Activate
Set rBereich = Range("A2:F10")
Application.ScreenUpdating = False
For Each rZelle In rBereich
If Trim$(rZelle) "" Then
rZelle.BorderAround xlContinuous, xlMedium
Else
rZelle.Borders.LineStyle = xlNone ' alle Linien löschen
End If
Next rZelle
End Sub Vielen Dank schon einmal im Voraus für Eure Hilfe
Gruß Richard
Anzeige