AW: Aktualisierung der Tabellen
10.08.2012 12:07:41
fcs
Hallo Ivek,
mit den folgenden Anpassungen sollte es funktionieren.
Gruß
Franz
'Code in einem allgemeinen Modul
Sub TabellenAktualisieren()
Dim wks As Worksheet, objShAktiv
Set objShAktiv = ActiveSheet
Application.ScreenUpdating = False
For Each wks In ActiveWorkbook.Worksheets
Select Case wks.Name
Case "ALL", "LAENDER"
'ggf. Namen der Tabellen nicht aktualisiert werden sollen
Case Else
Call AktualisierenBilder(wks)
End Select
Next
objShAktiv.Activate
Application.ScreenUpdating = True
End Sub
Sub AktualisierenBilder(ByVal wks As Worksheet)
wks.Activate
'ab hier dann das vorhande Makro der Schaltflächen
Dim strPfad As String
Dim strSNR As String
Dim strDateipfadBild As String
Dim xlEnd As Long
Dim i As Integer
Dim P
With wks
xlEnd = .Cells(.Rows.Count, 2).End(xlUp).Row
For Each P In .Shapes
If P.Name Like "*.jpg" Then P.Delete
Next P
For i = 4 To xlEnd
strPfad = .Cells(i, 6).Value
strSNR = .Cells(i, 2).Value
strDateipfadBild = strPfad & "\" & strSNR & ".jpg"
Call InsertPicture(wksInsert:=wks, strPfadBild:=strDateipfadBild, _
strSNR:=strSNR, Zeile:=i)
Next i
End With
End Sub
Sub InsertPicture(ByVal wksInsert As Worksheet, strPfadBild As String, _
strSNR As String, ByVal Zeile As Long)
Dim pct As Picture
Dim iLeft As Integer
Dim iTop As Integer
Dim iWidth As Integer
Dim iHeight As Integer
Dim sFile As String
Dim sinFaktor As Single
Application.EnableEvents = False
On Error GoTo FEHLER
sFile = strPfadBild
With wksInsert
With .Range(.Cells(Zeile, 1), .Cells(Zeile, 1))
iLeft = .Left
iTop = .Top
iWidth = .Width
iHeight = .Height
End With
Set pct = .Pictures.Insert(sFile)
End With
pct.Name = "test.jpg"
sinFaktor = iHeight / pct.Height - 0.03
pct.ShapeRange.ScaleWidth sinFaktor, msoFalse, msoScaleFromTopLeft
pct.ShapeRange.ScaleHeight sinFaktor, msoFalse, msoScaleFromTopLeft
pct.Left = iLeft + iWidth / 2 - pct.Width / 2
pct.Top = iTop + iHeight / 2 - pct.Height / 2
FEHLER:
Application.EnableEvents = True
wksInsert.Cells(Zeile, 1).Select
End Sub
Für die Commandbuttons in den Tabellenblättern dann:
Private Sub CommandButton1_Click()
Call TabellenAktualisieren
End Sub