Insert a picture from another worksheet

[sparky2205]

Hi folks,
I've inherited a spreadsheet that now requires changes.
The spreadsheet has a macro to update Pictograms based on a description that is populated earlier in the code.
Currently it is set up to populate the pictograms from a network location. I want to change this so that the pictograms are instead stored within the spreadsheet on a tab called "Pictograms".
Apologies for variable names in advance as the original spreadsheet is German.

What I currently have:

Set BILD = ActiveSheet.Pictures.Insert(ADRESSE + BEZEICHNUNG + ".png")

BILD is declared as a Picture
ADRESSE is a String to hold the network address
BEZEICHNUNG is a string to hold the picture name (i.e.pictogram name)

What I'm trying to achieve:

Set BILD = ActiveSheet.Pictures.Insert(Worksheets("Pictograms").shapes(BEZEICHNUNG)

This is in a loop which updates BEZEICHNUNG each time through the loop and inserts the appropriate picture.

This is producing a compile error: Expected: list separator or )

 

[Alex Blakenburg]

Give the looking up a table a miss for now, since that is will be quite a different approach. You need to either do Lookup function on the table or array, or use a dictionary.

It's only through @GWteB's very clear and quite elegant code that led me to think Select Case could work for you.
Below is how I think the select statement would look.
It does lead me to wonder about what you do with a code in terms of a picture when the code exists but the other conditions for the picture selection are not met.

I only really reworked all the If statements and got lazy in trying to figure out which Dim statements I needed for this part of the code so just dumped in all the Dim statements.

In your real code the TEXT variable is set by
TEXT = oWs.Cells(ZEILE, COLUMN).Value

Sub SelectCase_GEFAHRSTOFFSYMBOL()

    Dim ZEILE           As Long                  'ROW
    Dim ZEILE_ANFANG    As Long                  'LINE_START
    Dim ZEILE_ENDE      As Long                  'LINE_END
    Dim Next_Row_H      As Long                  'Last used row in column H
    Dim COLUMN          As Long
    Dim FIRST_COLUMN    As Long
    Dim LAST_COLUMN     As Long
    Dim FELD            As Long                  'FIELD
    Dim ZAEHLER         As Long                  'COUNTER
    Dim HOEHE           As Single                'HEIGHT
     
    Dim BRENNBAR        As Boolean               'FLAMMABLE
    Dim EXPLOSIV        As Boolean               'EXPLOSIVE
    Dim AETZEND         As Boolean               'CORRISIVE
    Dim GIFTIG          As Boolean               'POISONOUS
    Dim GESUNDHEITSSCHAEDLICH As Boolean         'HARMFUL

    Dim GHS1        As String
    Dim GHS2        As String
    Dim GHS3        As String
    Dim GHS4        As String
    Dim GHS5        As String
    Dim GHS6        As String
    Dim GHS7        As String
    Dim GHS8        As String
    Dim GHS9        As String
    Dim TEXT        As String
    Dim BEZEICHNUNG As String                    'DESCRIPTION
    Dim GHS_NUMMERN As String                    'GHS_NUMBERS
    Dim GHS_SYMBOLE As String                    'GHS_SYMBOL



                ' Test Value - in the real procedure this is pulled from a cell using a row, column reference
                TEXT = "H318"
                TEXT = Right(TEXT, 3)
                              
                        Select Case TEXT
                            Case 200, 201, 202, 203, 204, 240, 241
                                GHS1 = "Picture 1, "
                                EXPLOSIV = True
                           
                            Case 220, 222, 223, 224, 225, 228, 241, 242, 250, 252, 260, 261
                                If EXPLOSIV = False Then
                                    GHS2 = "Picture 2, "
                                    BRENNBAR = True  ' FLAMMABLE
                                End If
                               
                            Case 226, 251
                                 If EXPLOSIV = False Then
                                    GHS2 = "Picture 2, "
                                End If
                           
                            Case 270, 271, 272
                                If EXPLOSIV = False Then
                                    GHS3 = "Picture 3, "
                                End If
                           
                            Case 300, 301, 310, 311, 330, 331
                                GHS6 = "Picture 6, "
                                GIFTIG = True        ' POISONOUS
                           
                            Case 280, 281
                                If BRENNBAR = False Then
                                    If GIFTIG = False Then
                                            GHS4 = "Picture 4, "
                                    End If
                                End If
                           
                            Case 334
                                GHS8 = "Picture 8, "
                                GESUNDHEITSSCHAEDLICH = True ' HARMFUL
                           
                            Case 290, 314, 318
                                GHS5 = "Picture 5, "
                                AETZEND = True       ' CORROSIVE
                           
                            Case 304, 340, 341, 350, 351, 360, 361, 370, 371, 372, 373
                                GHS8 = "Picture 8, "
                           
                            Case 302, 312, 332
                                If GIFTIG = False Then
                                    GHS7 = "Picture 7, "
                                End If
                           
                            Case 315, 319
                                If GIFTIG = False Then
                                    If AETZEND = False Then
                                        If GESUNDHEITSSCHAEDLICH = False Then
                                                GHS7 = "Picture 7, "
                                        End If
                                    End If
                                End If
                           
                            Case 317
                                If GIFTIG = False Then
                                    If GESUNDHEITSSCHAEDLICH = False Then
                                        GHS7 = "Picture 7, "
                                    End If
                                End If
                       
                            Case 335, 336, 420
                                If GIFTIG = False Then
                                    GHS7 = "Picture 7, "
                                End If
                           
                            Case 400, 410, 411
                                 GHS9 = "Picture 9, "
                                
                            Case Else
                                ' Do nothing
                       
                        End Select

End Sub

 

[sparky2205]

Thanks Alex,
I'll take a look at this as soon as I get a chance. I'm just about to leave work.
Hopefully I'll get a chance to have a look over the weekend.
But if not, it'll be Tuesday.
Just don't want you to think I've lost interest.

 

[GWteB]

The extra functions StringContainsAny and StringContains in particular. These appear very complex compared to the previous code. I presume they are doing the actual checking of TEXT against the members of the array but what exactly is going on there .

Just a brief explanation. A snippet of your original code reads:

If InStr(TEXT, "200") Then

This line reads as in: look in variable TEXT's assigned string (hopefully there is one ...) and tell me if there is a presence of the string "200". If so, give me its character start position within that string, otherwise give me 0 (zero), both as a number, data type Long. Because of VBA's implicit data type conversion, this code runs without errors.
The shortest version of a VBA If ... Then statement is If True Then

Mentioned data conversion makes a 0 become FALSE ("200" was not present within TEXT) and any other number becomes TRUE ("200" was present within TEXT).
This line of code might as well have been written in the following two ways:

If InStr(TEXT, "200") = True Then
If InStr(TEXT, "200") > 0 Then

Now consider scenario & comments below, as an excerpt of your code:

Dim TEXT As String

TEXT = "About January 1st, 2000 some folks were afraid the millennium bug would kick in."

If InStr(TEXT, "199") Then      ' If TRUE then:  (being Skipped due to FALSE)
      GHS1 = "Picture 1, "      '   assignment 1
      EXPLOSIV = 1              '   assignment 2
End If
If InStr(TEXT, "200") Then      ' If TRUE then:  (Yeah, "200" was found)
      GHS1 = "Picture 1, "      '   also assignment 1
      EXPLOSIV = 1              '   also assignment 2
End If
If InStr(TEXT, "201") Then      ' If TRUE then:  (if "200" was found, why bother to compare against "201" since the assignments are exactly the same as the previous ones)
      GHS1 = "Picture 1, "      '   again assignment 1
      EXPLOSIV = 1              '   again assignment 2
End If

With the above in mind, we could create groups for each follow-up action to be performed, and then subject an entire group to a comparison at once, but with the understanding that the comparison process will be terminated prematurely if one element from that particular group is found.

This is where StringContainsAny comes in view (which in turn uses the also provided StringContains function, an extended version of the VBA InStr function with this difference, it doesn't return a number but just True or False). The "Any" suffix is pointing at the possibility to "inject" (practically) any VBA data type into this procedure. I coded it this way to be flexible so this function can be used within other scenarios as well. The injected data type could be a String, a Long, a Currency (even a Null or Empty, although this would be pointless but nevertheless would not (!!) result in a run-time error). In your project we are injecting a one dimensional Array data type carrying multiple elements. In this case the StringContainsAny function takes element by element for comparison against TEXT but with the specific condition, that if there was an element found, the result is returned immediately and thereby skipping the comparisson of the remaining elements. Both functions do some additional checks to prevent run-time errors or superfluous execution of code. For example, whats the point of looking for some string within a string that has no characters at all?

Use of custom made functions has some benefits in terms of decreasing the size of procedures (by code reuse), maintenance, debugging (step in/step over) and readability. Also, they become more specialized in their task and have fewer reasons to fail that way. To be honest, I have considered to pull the body of each loop into its own parameterized procedure scope, to obtain even more and better overview on what the code exactly does.

I then altered this line:
If StringContainsAny(TEXT, Array(200, 201, 202, 203, 204, 240, 241)) Then
to
If StringContainsAny(TEXT, Array(Worksheets("H-phrases").ListObjects("Table3").DataBodyRange.Value)) Then

This runs fine for the originally created table but if I add a value to the table it is not picked up when I run the program.

Can't suppress some surprise. With regard to arrays, the StringContainsAny procedure can only handle a 1 dimensional version with single elements. Although you're injecting a 1 dimensional array, it contains just one element which in turn contains a 2 dimensional array. The latter isn't processed, so you should always get FALSE as a result.

For better understanding, data coming from a multi cell range is always in a 2 dimensional array structure, even if it's just one column or one row. For a quick overview regarding the array data type have a look over here. So the StringContainsAny procedure has limitations but if we would take care of that, the function would increase in its size, would perform more than its primary task en would be less readable. Nonetheless, this function is quite useful. All we have to do is to convert the data we have to an appropriate structure, i.e. a 1 dimensional array:

    Dim arrIN As Variant, arrOut As Variant

    arrIN = ThisWorkbook.Worksheets("H-phrases").ListObjects("Table3").DataBodyRange.Value

    With Excel.Application
        arrOut = .Index(.Transpose(arrIN), 1, 0)
    End With

    If StringContainsAny(TEXT, arrOut) Then

The 1 in this code represents the column part, the 0 means that we're getting the entire column, as opposed to just for example the 1st, 2nd or 3rd (etc.) element of that column.

FYI, have done a test with a 2 column table without the use of an additional named range and the results were as expected. Have no clue why your table isn't updating.


Cheers!

 

[sparky2205]

Hi GWteB,
bad penny back again. I got a bit distracted by a few other things at work.

Can't suppress some surprise. With regard to arrays, the StringContainsAny procedure can only handle a 1 dimensional version with single elements. Although you're injecting a 1 dimensional array, it contains just one element which in turn contains a 2 dimensional array. The latter isn't processed, so you should always get FALSE as a result.

FYI, have done a test with a 2 column table without the use of an additional named range and the results were as expected. Have no clue why your table isn't updating.

Not quite sure from the above if you're telling me this code:
If StringContainsAny(TEXT, Array(Worksheets("H-phrases").ListObjects("Table3").DataBodyRange.Value)) Then
shouldn't work at all or it should be working fine and you can't understand why it's not.

It would have been nice to have been able to just update the H-phrases on a worksheet and have them picked up automatically on button click. That would have made the spreadsheet updateable by anyone. But those H-phrases won't change very often anyway so it's not a big deal.

Regardless, with the help both of you have given me I now have a spreadsheet that works.
Thanks again for all the help.

 

[GWteB]

I tried telling you, that I'm surprised that it works for you, since this is impossible.
The StringContainsAny function just processes 1 dimensional arrays containing single elements. A DataBodyRange object isn't a single element it this sence. It's returning a 2 dimensional array which isn't processed in this procedure. That's why I provided a conversion sulution in my previous post.

Anyway, glad to help and thanks for letting me know.

 

[sparky2205]

Hi GWteB,
it's me again .
I took the time to go through your code properly and as Alex said previously, very elegant.
I was also able to implement your 1 dimension to 2 dimension array converter to allow me to reference my tables of H-phrases rather than directly referencing them in the code.

I hope I didn't frustrate you to the point of exasperation while trying to understand your code in my own plodding way to the point where you'll now ignore me.
Because I'm looking for more help.
I don't know if it's related to the way I've implemented your array converter.
Link to download the file. List of Hazardous Substances.xlsm See, I am learning.
It's a bit like the previous problem I was having.
If I run the macro repeatedly it will eventually bomb out on this line: ThisWorkbook.Worksheets("Pictograms").Shapes(BEZEICHNUNG).Copy, with the error, Method 'Copy' of object 'Shape' failed.
If I then end on the error and run it one or two more times it closes the spreadsheet.
This started happening once or twice during testing but now it's happening very frequently.

I hope you can help me with this as I feel it's almost there but I don't have the level of knowledge you have to be able to successfully troubleshoot this error.
I thought of putting in an error handler which would simply inform the user of an error and request them to rerun the code but it's happening so frequently I don't think that's an option and I also can't be sure now that it's working correctly when I don't get the error. From the checks I've done it does appear to be but I would much prefer if I could know what is causing this error.

Thanks for any help you can provide.

 

[GWteB]

Your issue could be addressed by significantly increasing the value of variable MaxAttempts and intermittently yielding to the OS through DoEvents statement. However, it also turned out to be necessary to divide the code over two modules, after which no more crashes occurred. It looks like Excel doesn't like it when images are copied to another worksheet many times in succession. We had more or less found out about this at an earlier stage, hence the OnError workaround.
Although on repeated tests the built-in warning wasn't displayed anymore and Excel didn't crash no longer, I couldn't be quite happy with it. On my 10 years old machine it resulted in a flickering screen and a duration of about 25 seconds. I was forced to both change the approach and completely overhaul the code.

The main changes:

• the different symbols each are copied only once from the hidden worksheet to the visible worksheet and the dimensions of each are resized;
• from there they are copied as desired and deleted again afterwards;
• the frequently repeated access to worksheet ranges has been reduced to a minimum, all comparisons and necessary data transfers now take place in the computer's memory and, if necessary, are written to the worksheet in one go afterwards.

Hopefully you can still find your way around it, but at least the code now does what it's supposed to do without arguing and within one (1) second.

The main procedure:

Public Sub GEFAHRSTOFFSYMBOL_MREXCEL()           ' hazardous substance symbol

    Const ZEILE_ANFANG  As Long = 5              'Ab welcher Zele sollen die GHS-Symbole eingesetzt werden --- From which row should the GHS symbols be used
    Const FIRST_COLUMN  As Long = 10             'First column containing a H number
    Const LAST_COLUMN   As Long = 17             'Last column containing a H number
    Const HOEHE         As Single = 29           'Wie hoch sollen die GHS-Symbole sein --- How high should the GHS symbols be

    Const COL_GHS_NUMMERN   As String = "I"      'In welche Spalte sollen die GHS-Nummern eingefügt werden --- In which column should the GHS numbers be inserted
    Const COL_GHS_SYMBOLE   As String = "H"      'In welche Spalte sollen die GHS-Symbole eingesetzt werden --- In which column should the GHS symbols be placed


    Dim ZEILE           As Long                  'ROW
    Dim ZEILE_ENDE      As Long                  'LINE_END
    Dim COLUMN          As Long
      
    Dim BRENNBAR        As Boolean               'FLAMMABLE
    Dim EXPLOSIV        As Boolean               'EXPLOSIVE
    Dim AETZEND         As Boolean               'CORRISIVE
    Dim GIFTIG          As Boolean               'POISONOUS
    Dim GESUNDHEITSSCHAEDLICH As Boolean         'HARMFUL
    
    Dim arrOut          As Variant               ' temporary one dimensional array storage for H-Phrases tables on worksheet
    Dim arrForSymbols   As Variant               ' two dimensional array for comparison purpose
    Dim arrGHSNumbers   As Variant               ' two dimensional array for intermediate storage GHS Numbers
        
    Dim arrGHSTables(1 To 9)    As Variant
    Dim arrP(1 To 9)            As Boolean
    Dim arrGHSTotals(1 To 9)    As String

    Dim TEXT        As String
    Dim TEXT1       As String
    
    'Hier kommt der Definitionsteil, in dem alle Parameter eingestellt werden
    'Here comes the definition part, in which all parameters are set
    '************************************************************************

    '************************************************************************
    'Hier endet der Definitionsteil, in dem alle Parameter eingestellt werden
    'This is where the definition section ends, in which all parameters are set

    'Folgende Ausschlussbedingungen gibt es:
    'There are the following exclusion conditions:
    '************************************************************************
      
    'a) Wenn GHS01 dann kein GHS02 und GHS03 --- IF GHS01 THEN NO GHS02 AND GHS03
    'b) Wenn GHS06 dann kein GHS07 --- IF GHS06 THEN NO GHS07
    'c) Wenn GHS05 und H315 oder H319 dann kein GHS07 --- IF GHS05 AND H315 OR H319 THEN NO GHS07
    'd) WENN GHS08 und H315 oder H317 oder H319 dann kein GHS07 --- IF GHS08 AND H315 OR H317 OR H319 THEN NO GHS07
    'e) Wenn GHS02 oder GHS06 dann kein GHS04 --- IF GHS02 OR GHS06 THEN NO GHS04
      
    '************************************************************************
    'Hier endet die Beschreibung der Ausschlussbedingungen
    'The description of the exclusion conditions ends here


      
    ' explicit declaration recommended
    Dim oWs     As Worksheet
    Dim ActCell As Range

    For Each oWs In ThisWorkbook.Worksheets      'Folgende Routine setzt alle Filterungen zurück, da sonst das Programm nicht richtig funktioniert --- The following routine removes all filters, otherwise the program will not work properly
        With oWs
            If .FilterMode Then .ShowAllData
        End With
    Next oWs

    ' set a proper reference to destination worksheet with name Tabelle2 (reference can and will be reused)
    Set oWs = ThisWorkbook.Worksheets("Tabelle2")

    ' proceed if the intended sheet is also the current displayed sheet, otherwise jump to corresponding End If
    If ActiveSheet.Parent.Name = oWs.Parent.Name And ActiveSheet.Name = oWs.Name Then

        ' store ActiveCell (and restore it afterwards) so none of the inserted pictures stays selected when we're finished
        Set ActCell = ActiveCell

        ' determine the last used row within column A dynamically
        ZEILE_ENDE = oWs.Cells(oWs.Rows.Count, "A").End(xlUp).Row 'Bis zu welcher Zele sollen die GHS-Symbole eingesetzt werden --- Up to which line should the GHS symbols be used (Get the last used row)

        ' ensure proper column width
        oWs.Columns(COL_GHS_SYMBOLE).ColumnWidth = HOEHE 'HEIGHT
        
        ' Bei jedem Programmaufruf werden alle Bilder erst einmal gelöscht, sonst würden immer mehr Bilder übereinander abgelegt --- Each time the program is called, all images are first deleted, otherwise more and more images would be stored on top of each other
        oWs.Pictures.Delete
        oWs.Range("I5:I" & ZEILE_ENDE).ClearContents
            
        DoEvents
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual

        ' >> process data within memory rather than frequent read/write access to worksheet range
        arrForSymbols = oWs.Range(oWs.Cells(ZEILE_ANFANG, FIRST_COLUMN), oWs.Cells(ZEILE_ENDE, LAST_COLUMN)).Value
        arrGHSNumbers = oWs.Range(oWs.Cells(ZEILE_ANFANG, COL_GHS_NUMMERN), oWs.Cells(ZEILE_ENDE, COL_GHS_NUMMERN)).Value

        ' >> copy all worksheet GHS Tables to memory
        With ThisWorkbook.Worksheets("H-phrases")
            arrOut = Slice2DArrayFromTable(.ListObjects("Table3"), 1)
            arrGHSTables(1) = arrOut
            arrOut = Slice2DArrayFromTable(.ListObjects("Table4"), 1)
            arrGHSTables(2) = arrOut
            arrOut = Slice2DArrayFromTable(.ListObjects("Table5"), 1)
            arrGHSTables(3) = arrOut
            arrOut = Slice2DArrayFromTable(.ListObjects("Table6"), 1)
            arrGHSTables(4) = arrOut
            arrOut = Slice2DArrayFromTable(.ListObjects("Table7"), 1)
            arrGHSTables(5) = arrOut
            arrOut = Slice2DArrayFromTable(.ListObjects("Table8"), 1)
            arrGHSTables(6) = arrOut
            arrOut = Slice2DArrayFromTable(.ListObjects("Table9"), 1)
            arrGHSTables(7) = arrOut
            arrOut = Slice2DArrayFromTable(.ListObjects("Table10"), 1)
            arrGHSTables(8) = arrOut
            arrOut = Slice2DArrayFromTable(.ListObjects("Table11"), 1)
            arrGHSTables(9) = arrOut
        End With

        Dim rw As Long, cn As Long

        ' process rows
        For rw = LBound(arrForSymbols, 1) To UBound(arrForSymbols, 1)

            ' initialize necessary variables
            Dim i As Long
            For i = LBound(arrGHSTotals) To UBound(arrGHSTotals)
                arrGHSTotals(i) = ""
                arrP(i) = False
            Next i
            TEXT1 = ""

            BRENNBAR = False                     ' FLAMMABLE
            EXPLOSIV = False                     ' EXPLOSIVE
            AETZEND = False                      ' CORROSIVE
            GIFTIG = False                       ' POISONOUS
            GESUNDHEITSSCHAEDLICH = False        ' HARMFUL

            ' process columns
            For cn = LBound(arrForSymbols, 2) To UBound(arrForSymbols, 2)

                TEXT = arrForSymbols(rw, cn)

                ' if variable TEXT doesn't contain a string (so it's length equals zero) there would be nothing to compare against
                ' in that case:         do nothing, jump to corresponding End If;
                ' in any other case:    proceed with next line

                If Len(TEXT) > 0 Then

                    '=====================================================================================

                    'If StringContainsAny(TEXT, Array(200, 201, 202, 203, 204, 240, 241)) Then
                    If StringContainsAny(TEXT, arrGHSTables(1)) Then
                        arrGHSTotals(1) = "Picture 1, "
                        EXPLOSIV = True
                        arrP(1) = True
                    End If
                    '=====================================================================================
                    If EXPLOSIV = False Then
                        If StringContainsAny(TEXT, Array(220, 222, 223, 224, 225, 228, 241, 242, 250, 252, 260, 261)) Then
                            arrGHSTotals(2) = "Picture 2, "
                            BRENNBAR = True  ' FLAMMABLE
                            arrP(2) = True
                        End If
                        If StringContainsAny(TEXT, Array(226, 251)) Then
                            arrGHSTotals(2) = "Picture 2, "
                            arrP(2) = True
                        End If
                        'If StringContainsAny(TEXT, Array(270, 271, 272)) Then
                        If StringContainsAny(TEXT, arrGHSTables(3)) Then
                            arrGHSTotals(3) = "Picture 3, "
                            arrP(3) = True
                        End If
                    End If
                    '=====================================================================================
                    'If StringContainsAny(TEXT, Array(300, 301, 310, 311, 330, 331)) Then
                    If StringContainsAny(TEXT, arrGHSTables(6)) Then
                        arrGHSTotals(6) = "Picture 6, "
                        GIFTIG = True        ' POISONOUS
                        arrP(6) = True
                    End If
                    '=====================================================================================
                    
                    If BRENNBAR = False Then
                        If GIFTIG = False Then
                            'If StringContainsAny(TEXT, Array(280, 281)) Then
                            If StringContainsAny(TEXT, arrGHSTables(4)) Then
                                arrGHSTotals(4) = "Picture 4, "
                                arrP(4) = True
                            End If
                        End If
                    End If
                    '====================================================================================
                    'If StringContainsAny(TEXT, Array(290, 314, 318)) Then
                    If StringContainsAny(TEXT, arrGHSTables(5)) Then
                        arrGHSTotals(5) = "Picture 5, "
                        AETZEND = True       ' CORROSIVE
                        arrP(5) = True
                    End If
                    '===================================================================================
                    If StringContainsAny(TEXT, Array(334)) Then
                        arrGHSTotals(8) = "Picture 8, "
                        GESUNDHEITSSCHAEDLICH = True ' HARMFUL
                        arrP(8) = True
                    End If
                    '===================================================================================
                    'If StringContainsAny(TEXT, Array(304, 340, 341, 350, 351, 360, 361, 370, 371, 372, 373)) Then
                    If StringContainsAny(TEXT, arrGHSTables(8)) Then
                        arrGHSTotals(8) = "Picture 8, "
                        arrP(8) = True
                    End If
                    '===================================================================================
                    If GIFTIG = False Then
                        'If StringContainsAny(TEXT, Array(302, 312, 332)) Then
                        If StringContainsAny(TEXT, arrGHSTables(7)) Then
                            arrGHSTotals(7) = "Picture 7, "
                            arrP(7) = True
                        End If

                        If AETZEND = False Then
                            If GESUNDHEITSSCHAEDLICH = False Then
                                If StringContainsAny(TEXT, Array(315, 319)) Then
                                    'If StringContainsAny(TEXT, arrOut) Then
                                    arrGHSTotals(7) = "Picture 7, "
                                    arrP(7) = True
                                End If
                            End If
                        End If
              
                        If GESUNDHEITSSCHAEDLICH = False Then
                            If StringContainsAny(TEXT, Array(317)) Then
                                'If StringContainsAny(TEXT, arrOut) Then
                                arrGHSTotals(7) = "Picture 7, "
                                arrP(7) = True
                            End If
                        End If

                        If StringContainsAny(TEXT, Array(335, 336, 420)) Then
                            'If StringContainsAny(TEXT, arrOut) Then
                            arrGHSTotals(7) = "Picture 7, "
                            arrP(7) = True
                        End If
                    End If
                    '===============================================================================
                    'If StringContainsAny(TEXT, Array(400, 410, 411)) Then
                    If StringContainsAny(TEXT, arrGHSTables(9)) Then
                        arrGHSTotals(9) = "Picture 9, "
                        arrP(9) = True
                    End If
                    '==============================================================================
                End If
                TEXT1 = TEXT + TEXT1
        
            Next cn
            
            '=================================================================================================================
            'Exclusions:
            'IF GHS01 THEN NO GHS02 OR GHS03. Without this line if GHS02 OR GSH03 is before GHS01 the exclusion will not work.
            If arrP(1) = True Then arrGHSTotals(2) = ""
            If arrP(1) = True Then arrGHSTotals(3) = ""

            'IF GHS02 OR GHS06 THEN NO GHS04. Without this line if GHS04 is before GHS02 or GHS06 the exclusion will not work.
            If arrP(2) = True Or arrP(6) = True Then arrGHSTotals(4) = ""

            'IF GHS06 THEN NO GHS07. Without this line if GHS07 is before GHS06 the exclusion will not work.
            If arrP(6) = True Then arrGHSTotals(7) = ""
            
            'IF GHS05 AND H315 OR H319 THEN NO GHS07
            If arrP(5) = True And InStr(TEXT1, "H315") Then arrGHSTotals(7) = ""
            If arrP(5) = True And InStr(TEXT1, "H319") Then arrGHSTotals(7) = ""
            
            
            'If AETZEND = True And InStr(TEXT1, "H319") Then GHS7 = ""
            'IF GHS08 AND H315 OR H317 OR H319 THEN NO GHS07
            If arrP(8) = True And InStr(TEXT1, "H315") Then arrGHSTotals(7) = ""
            If arrP(8) = True And InStr(TEXT1, "H317") Then arrGHSTotals(7) = ""
            If arrP(8) = True And InStr(TEXT1, "H319") Then arrGHSTotals(7) = ""
            
            'If GESUNDHEITSSCHAEDLICH = True And InStr(TEXT1, "H315") Then GHS7 = ""
            '=================================================================================================================
            
            'oWs.Range(COL_GHS_NUMMERN & ZEILE) = oWs.Range(COL_GHS_NUMMERN & ZEILE) & GHS1 & GHS2 & GHS3 & GHS4 & GHS5 & GHS6 & GHS7 & GHS8 & GHS9 ' GHS_NUMBERS & ROW)
            For i = LBound(arrGHSTotals) To UBound(arrGHSTotals)
                arrGHSNumbers(rw, 1) = arrGHSNumbers(rw, 1) & arrGHSTotals(i)
            Next i
            'arrGHSNumbers(rw, 1) = GHS1 & GHS2 & GHS3 & GHS4 & GHS5 & GHS6 & GHS7 & GHS8 & GHS9
            '        Next ZEILE
        Next rw
            
        ' write processed data back to worksheet
        oWs.Range(Cells(ZEILE_ANFANG, COL_GHS_NUMMERN).Address).Resize(UBound(arrGHSNumbers, 1)).Value = arrGHSNumbers
        
        
        Dim RowsToAdjust    As Range         ' << ensure a proper row height
        Dim PictureCount    As Long          ' << just for informative Message Box
        Dim Result          As VbMsgBoxResult
        Dim TempPics        As ShapeRange
        Dim Shp             As Shape

        Result = vbOK
        Set TempPics = GetTempPicturesAndResize(oWs, HOEHE, Result)
        If Result = vbCancel Then
            GoTo SUB_Cancel
        End If
    
        ' row numbers are used for correct placement of the images
        For ZEILE = ZEILE_ANFANG To ZEILE_ENDE      'Jede Zeile wird überprüft --- Every line is checked

            ' first rownumber is 5, array is 1 based so correction of -4
            TEXT = arrGHSNumbers(ZEILE - 4, 1)
            
            ' duplicate image
            DupRelatedPicture oWs, TEXT, COL_GHS_SYMBOLE, ZEILE, PictureCount
        
            ' keep track of rows of which height should be adjusted
            If oWs.Rows(ZEILE).Height < HOEHE + 5 Then
                If RowsToAdjust Is Nothing Then
                    Set RowsToAdjust = oWs.Rows(ZEILE)
                Else
                    Set RowsToAdjust = Application.Union(RowsToAdjust, oWs.Rows(ZEILE))
                End If
            End If

        Next ZEILE
        
        ' adjust rows in one go
        RowsToAdjust.RowHeight = HOEHE + 5

SUB_Cancel:

        ' reposition Excel's selector where it initial came from
        ActCell.Activate
        ' delete temporary images
        TempPics.Delete

    End If

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub

The main precedure's dependencies, to be pasted in a separate standard module:

Public Function Slice2DArrayFromTable(ByVal argTable As ListObject, ByVal argColumn As Long) As Variant
    Dim arrIN As Variant
    arrIN = argTable.DataBodyRange.Value
    With Excel.Application
        Slice2DArrayFromTable = .Index(.Transpose(arrIN), argColumn, 0)
    End With
End Function


Public Sub DupRelatedPicture(ByVal argSht As Worksheet, ByVal argText As String, ByVal argGHSSymbol As String, ByVal argRow As Long, ByRef argPictureCount As Long)

    Dim FELD                    As Long
    Dim BEZEICHNUNG             As String
    Dim NextImagePositionLeft   As Single
    Dim Shp                     As Shape
    Dim raDestination           As Range

    If Len(argText) > 0 Then

        Set raDestination = argSht.Range(argGHSSymbol & CStr(argRow))

        For FELD = 1 To 9                           'Jedes Gefahrensymbol wird gesucht --- Every danger symbol is searched for

            BEZEICHNUNG = "Picture " & CStr(FELD)   '"GHS0?" ' DESCRIPTION

            If InStr(argText, BEZEICHNUNG) > 0 Then

                Set Shp = argSht.Shapes(BEZEICHNUNG).Duplicate
                Shp.Top = raDestination.Top + 2
                Shp.Left = raDestination.Left + 2 + NextImagePositionLeft
                NextImagePositionLeft = NextImagePositionLeft + Shp.Width
                argPictureCount = argPictureCount + 1
            End If
        Next FELD
    End If
End Sub


Public Function GetTempPicturesAndResize(ByVal argDestSht As Worksheet, ByVal argHeight As Single, ByRef argResult As VbMsgBoxResult) As ShapeRange

    Dim arr()           As String
    Dim Shp             As Shape
    Dim ShpJustPasted   As Picture
    Dim ErrorNumber     As Long
    Dim MaxAttempts     As Long
    Dim Attempts        As Long
    Dim i               As Long

    With ThisWorkbook.Worksheets("Pictograms")
        For Each Shp In .Shapes
            Shp.Copy
            ' ------------------------------------------------------------------------
            '        Prevent some mysterious, not consistent behavior:
            '        VBA randomly throws a run-time error on the Worksheet.Paste method

FUNC_Retry:
            MaxAttempts = 100                   ' <<<<<  change maximum amount of attempts to suit
            Attempts = 0
            ErrorNumber = -1

            Do Until Attempts = MaxAttempts
                If Attempts Mod 24 = 0 Then DoEvents    ' yield to OS if necessary
                On Error Resume Next
                argDestSht.Paste                 ' raDestination  ' <<< Do NOT define a destination Range
                ErrorNumber = Err.Number                          '     just paste picture, it will be deleted afterwards
                Err.Clear
                On Error GoTo 0
                If Not CBool(ErrorNumber) Then
                    Exit Do
                Else
                    Attempts = Attempts + 1
                End If
            Loop
            If CBool(ErrorNumber) Then
                argResult = MsgBox("Error on pasting pictures, maximum amount of attempts has been reached.", vbExclamation + vbRetryCancel, "Gefahrstoffsymbol")
            End If
            If argResult = vbRetry Then GoTo FUNC_Retry
            If argResult = vbCancel Then Exit For
            ' -------------------------------------------------------------------------

            Set ShpJustPasted = argDestSht.Pictures(argDestSht.Pictures.Count)
            With ShpJustPasted
                .Name = Shp.Name
                ReDim Preserve arr(i)
                arr(i) = .Name
                i = i + 1
                .Locked = False
                .Placement = xlMove
                .ShapeRange.LockAspectRatio = msoFalse
                .Height = argHeight
                .Width = argHeight
                .Top = 4
                .Left = 4
            End With
        Next
        Set GetTempPicturesAndResize = argDestSht.Shapes.Range(arr)
    End With
End Function


Public Function StringContainsAny(ByVal argLookIn As String, ByRef argSearchFor As Variant) As Boolean
    Dim i As Long, s As String
    If argLookIn <> vbNullString Then
        If VarType(argSearchFor) And vbArray Then
            ' only one dimensional arrays supported
            For i = LBound(argSearchFor) To UBound(argSearchFor)
                On Error Resume Next
                s = CStr(argSearchFor(i))
                On Error GoTo 0
                If StringContains(argLookIn, s) Then
                    StringContainsAny = True
                    Exit For
                End If
            Next i
        Else
            On Error Resume Next
            s = CStr(argSearchFor)
            On Error GoTo 0
            StringContainsAny = StringContains(argLookIn, s)
        End If
    End If
End Function


Public Function StringContains(ByVal argLookIn As String, ByVal argSearchFor As String, Optional ByVal argCaseSensitive As Boolean = False) As Boolean
    Dim CompMethod As VbCompareMethod
    If argCaseSensitive Then
        CompMethod = vbBinaryCompare
    Else
        CompMethod = vbTextCompare
    End If
    StringContains = (Len(argSearchFor) > 0) And CBool(InStr(1, CStr(argLookIn), CStr(argSearchFor), CompMethod))
End Function

 

[sparky2205]

Hi GwteB,
thanks a million for sticking with me on this one. I really appreciate it.
My apologies for not responding sooner but I was doing some rigorous testing to make sure everything was ok.
I transferred your code to my spreadsheet and everything worked fine when all the data was populated.
This file will be used by a number of sites so I deleted all the data from the file.
Then I entered the word Test into A5 and H200 into J5. This should be sufficient to generate the pictogram. Or it was in the previous version.
At this point I get the error:

on arrGHSNumbers(rw, 1) = arrGHSNumbers(rw, 1) & arrGHSTotals(i)

I did some more testing with actual data and found the following:
In the file in the attached link List of Hazardous Substances - 27 Sep 21.xlsm all is well. Click the button and the pictograms are updated.
However, when I delete the last row of data and rerun the code an error occurs.

on RowsToAdjust.RowHeight = HOEHE + 5

If I restore the last row of data it works fine again. Not sure what the issue is with that row.

I need to be able to create a spreadsheet with no data in it that the user can then populate from scratch.
Thanks again for your help.

 

[GWteB]

I need to be able to create a spreadsheet with no data in it that the user can then populate from scratch.

Hopefully you're referring to only the main sheet (Tabelle2)?!?!

 

[sparky2205]

Hopefully you're referring to only the main sheet (Tabelle2)?!?!

Yes, the problem is on the main sheet.