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.

Reacties

Populaire posts van deze blog

Excel 2013: uniek aantal in draaitabel

Tot en met versie 2010 was het in Excel lastig om in een draaitabel een uniek aantal (DISTINCT COUNT) te tellen. We geven een voorbeeld op basis van een verkoperslijst. In deze lijst kunnen we zien welke verkopers welke artikelen hebben verkocht. Willen we nu in een draaitabel laten zien hoeveel artikelen een verkoper heeft verkocht, dan krijgen we wel de aantallen maar niet de unieke aantallen te zien. Om toch de unieke aantallen te laten zien, hebben we een aantal stappen nodig. Op het moment dat we de draaitabel invoegen, krijgen we in Excel 2013 dit dialoogvenster: Onderaan zien we daar een nieuwe optie: Deze gegevens toevoegen aan het gegevensmodel . Deze optie moeten we aanvinken, voor we op OK klikken. We krijgen dan een iets ander beeld dan normaal: Normaliter krijgen we alleen de veldnamen. Nu zien we er het woord Bereik boven staan. Voor het voorbeeld heb ik nu Verkoper toegevoegd aan Rijen en Artikelomschrijving aan Waarden . Het resultaat is identiek

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 66: For m = 32 To 126                         ActiveSheet.Unprotect Chr(a) & Chr(b) & _   Chr(c) & Chr(d) & Chr(e) & Chr(f) & _   Chr(g) & Chr(h) &  Chr(I) & Chr(j) & C

Friesland: MTB elfstedentocht 2016

Al snel na het helaas niet voltooien van de winterfietselfstedentocht rijpt bij mij het idee mee te doen aan de MTB elfstedentocht. Het moet mijn vijfde elfstedentocht worden na het wandelen, fietsen, steppen en kajakken. Al heb ik van deelnemers begrepen dat deze MTB tocht wel heel erg zwaar is. Drie dagen lang beulen. Ik vraag me af of het voor mij wel haalbaar is. Toch haal ik het in het najaar mijn al twintig jaar oude MTB van stal en begin alvast wat te trainen. Rond de stad Groningen blijken tal van oude landwegen en graspaden in het nieuw aangelegde De Onlanden mooie trainingsparcoursen op te leveren. Tegelijk hou ik de website van de organisator in de gaten:  http://mtb-xperience.nl/mountainbike-evenementen . In de loop van het voorjaar worden op deze website een aantal zaken duidelijk. Het wordt na vijf jaar mogelijk de laatste keer dat deze tocht georganiseerd wordt en de tocht wordt ook opengesteld voor individuele deelnemers. Tot nu toe kon je namelijk alleen in teamv