Doorgaan naar hoofdcontent

Excel: VBA en het zoeken en plaatsen van plaatjes bij producten

Laatste tijd een aantal keren mensen gezien die in Excel werken met een productenlijst met plaatjes. Die plaatjes plakken ze er dan zelf bij. Wat een werk! Met VBA is zoiets simpel te regelen. Plaatjes worden automatisch bij het artikelnummer gezocht en eventueel vernieuwd. Uiteraard moet er wel een map met plaatjes zijn en moeten de namen van de plaatjes gerelateerd zijn aan het artikelnummer.

In het onderstaande voorbeeld heb ik dit uitgewerkt.


Het Excel voorbeeld bestaat uit twee bladen. De eerste heet Plaatjes en bevat de artikelnummers en een knop. Bij een druk op deze knop zoekt het VBA script het juiste plaatje erbij. Wordt dit niet gevonden dan plaatst het een blauwe cirkel met een kruis. De regelhoogte en de grootte van het plaatje worden automatisch ingesteld aan de hand van variabelen uit het tweede blad.

 Het tweede blad heet Constanten. Hierin worden een aantal instellingen gedefinieerd:

Naam Inhoud
Pad D:\walmar domino\images\
Extensie .jpg
Afstand links 100
Breedte 70
Hoogte 70

Het VBA script ziet er als volgt uit:

Sub plaatjestoevoegen()
    'definiëren variabelen
    Dim shpPlaatje As Shape
    Dim intLinks As Integer, intTop As Integer, intBreedte As Integer, intHoogte As Integer
    Dim intRows As Integer
    Dim rngCel As Range
    Dim strPad As String, strExtensie As String
    
    'vullen variabelen
    'kunnen ook uit een constantenblad komen
    strPad = Worksheets("constanten").Range("b2")
    strExtensie = Worksheets("constanten").Range("b3")
    intLinks = Worksheets("constanten").Range("b4")
    intBreedte = Worksheets("constanten").Range("b5")
    intHoogte = Worksheets("constanten").Range("b6")
    
    intTop = Rows("1:1").RowHeight
    intRows = ActiveSheet.UsedRange.Rows.Count
    
    'juiste blad activeren
    Worksheets("plaatjes").Activate
    
    'rijhoogte instellen voor het gebied met plaatjes
    ActiveSheet.Rows("2:" & intRows).RowHeight = 15
    ActiveSheet.Rows("2:" & intRows).RowHeight = intHoogte
    
    'wissen aanwezige plaatjes, behalve button; vervangen lukt niet met VBA
    For Each shpPlaatje In ActiveSheet.Shapes
        If shpPlaatje.Name <> "Button 3" Then
            shpPlaatje.Delete
        End If
    Next
    
    'plaatsen plaatjes
    For Each rngCel In ActiveSheet.UsedRange.Columns(1).Cells
        If rngCel.Address <> "$A$1" Then
            'testen of plaatje bestaat
            If Dir(strPad & rngCel.Value & strExtensie) <> "" Then
                ActiveSheet.Shapes.AddPicture strPad & rngCel.Value & strExtensie, _
                True, True, intLinks, intTop, intBreedte, intHoogte
            Else
                ActiveSheet.Shapes.AddShape(msoShapeFlowchartSummingJunction, intLinks, _                       intTop, intBreedte, intHoogte).Select
            End If
            intTop = intTop + intHoogte
        End If
    Next

     'A1 selecteren
    ActiveSheet.Cells(1, 1).Select
End Sub



Voor verder Excel tips klik hier.
Labels:

Reacties

Een reactie posten

Populaire posts van deze blog

Friesland: nu ruim 1500 Friese familiewapens doorzoekbaar

Inleiding Het totale overzicht is nu ook als PDF te downloaden: rptWapens Al jaren verzamel ik de teksten van grafzerken en andere voorwerpen om ze in een database bijeen te brengen. Op heel veel oude grafzerken, rouwborden of andere voorwerpen in Friesland treffen we naast tekst ook vaak familiewapens aan. Ruim een jaar geleden ben ik gestart met het koppelen van familiewapens aan deze teksten. Met behulp van deze database kunnen we nu steeds meer voorheen onbekende wapens thuisbrengen of andersom, initialen herleiden tot de bijbehorende namen. Een voorbeeld. Zo kennen we uit het boek Fries Zilver nummer 894 met de tekst: TDH RBB 1669 Tjitte D. Wijngaarden geboren 6 october 1874 Daarbij een mannen- en een vrouwenwapen. Mannenwapen blijkt dat van Hoitinga te zijn. De letters blijken vervolgens te herleiden tot Tjepke Douwes Hoitinga en Rienkje Bouwes Bruinsma uit Nijland. Vermoedelijk getrouwd in 1669! Opgelost. Ander voorbeeld. Op een lepel uit het boek Dokk...
1 reactie
Meer lezen

Excel: VBA script om wachtwoord te verwijderen

Af en toe krijg ik een vraag om een wachtwoord van een Excel blad te halen. Doodsimpel met VBA. Hier een script dat ik gebruik: Sub WachtwoordCrack()     Dim a As Integer, b As Integer, c As Integer, d As Integer, _     e As Integer, f As Integer, g As Integer, h As Integer, _  I As Integer, j As Integer, k, m As Integer     Dim begin As Date, eind As Date     Dim duur As String     Dim objSheet As Worksheet     begin = TimeValue(Time)     On Error Resume Next     For Each objSheet In Application.Worksheets         For a = 65 To 66: For b = 65 To 66: For c = 65 To 66             For d = 65 To 66: For e = 65 To 66: For f = 65 To 66                 For g = 65 To 66: For h = 65 To 66: For I = 65 To 66                     For j = 65 To 66: For k = 65 To...
1 reactie
Meer lezen

Excel: Creating Your Own Tabs With XML And VBA

In order to create you own nice looking tabs you need the Custom UI Editor for Microsoft Office. You can download it for free. How is this different from choosing File , Options , Customize Ribbon and adding a new tab with new groups and then commands to the group? You can also move the new tab to any position. T hen your new tab is always there. Even when you don't open the specific file with the right VBA. In my example the outcome looks like this, a nice tab, placed in front of the Home Tab. You will only get this tab when you start the specific example (which you can download). The XML behind this: <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">    <ribbon startFromScratch="false">     <tabs>       <tab id="MaxIlze" label="Dossier Overzicht" insertBeforeMso="TabHome">         <group id="customGroup1" label="Adressen verrijken">         ...
Een reactie posten
Meer lezen