Option Explicit
Private IsRunning As Boolean
Public Sub Schaltfläche10_Klicken() 'BUTTON10CLICK
If Not IsRunning Then
IsRunning = True
GEFAHRSTOFFSYMBOL 'TABLE1.HAZARDOUS SUBSTANCE SYMBOL --- CALL THE FUNCTION IN Tabelle1
IsRunning = False
End If
End Sub
Private Sub GEFAHRSTOFFSYMBOL() ' hazardous substance symbol
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
'Hier kommt der Definitionsteil, in dem alle Parameter eingestellt werden
'Here comes the definition part, in which all parameters are set
'************************************************************************
ZEILE_ANFANG = 5 'Ab welcher Zele sollen die GHS-Symbole eingesetzt werden --- From which row should the GHS symbols be used
FIRST_COLUMN = 10 'First column containing a H number
LAST_COLUMN = 17 'Last column containing a H number
GHS_NUMMERN = "I" 'In welche Spalte sollen die GHS-Nummern eingefügt werden --- In which column should the GHS numbers be inserted
HOEHE = 29 'Wie hoch sollen die GHS-Symbole sein --- How high should the GHS symbols be
GHS_SYMBOLE = "H" 'In welche Spalte sollen die GHS-Symbole eingesetzt werden --- In which column should the GHS symbols be placed
'************************************************************************
'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
Application.ScreenUpdating = False
Application.EnableEvents = False
' GWteB
' 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
' GWteB
' set a proper reference to destination worksheet with name Tabelle2 (reference can and will be reused)
Set oWs = ThisWorkbook.Worksheets("Tabelle2")
' GWteB
' proceed if te 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
' GWteB
' store ActiveCell (and restore it afterwards) so none of the inserted pictures stays selected when we're finished
Set ActCell = ActiveCell
' GWteB
' multiple use of the worksheet reference named oWs on next few lines
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)
oWs.Pictures.Delete '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.Range("I5:I" & ZEILE_ENDE).ClearContents
oWs.Columns(GHS_SYMBOLE).ColumnWidth = HOEHE 'HEIGHT
For ZEILE = ZEILE_ANFANG To ZEILE_ENDE 'FOR ROW = ROW_START TO ROW_END
For COLUMN = FIRST_COLUMN To LAST_COLUMN
GHS1 = ""
GHS2 = ""
GHS3 = ""
GHS4 = ""
GHS5 = ""
GHS6 = ""
GHS7 = ""
GHS8 = ""
GHS9 = ""
TEXT = oWs.Cells(ZEILE, COLUMN).Value
' GWteB
' 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
BRENNBAR = False ' FLAMMABLE
EXPLOSIV = False ' EXPLOSIVE
AETZEND = False ' CORROSIVE
GIFTIG = False ' POISONOUS
GESUNDHEITSSCHAEDLICH = False ' HARMFUL
If StringContainsAny(TEXT, Array(200, 201, 202, 203, 204, 240, 241)) Then
GHS1 = "Picture 1, "
EXPLOSIV = True
End If
If EXPLOSIV = False Then
If StringContainsAny(TEXT, Array(220, 222, 223, 224, 225, 228, 241, 242, 250, 252, 260, 261)) Then
GHS2 = "Picture 2, "
BRENNBAR = True ' FLAMMABLE
End If
If StringContainsAny(TEXT, Array(226, 251)) Then
GHS2 = "Picture 2, "
End If
If StringContainsAny(TEXT, Array(270, 271, 272)) Then
GHS3 = "Picture 3, "
End If
End If
If StringContainsAny(TEXT, Array(300, 301, 310, 311, 330, 331)) Then
GHS6 = "Picture 6, "
GIFTIG = True ' POISONOUS
End If
If BRENNBAR = False Then
If GIFTIG = False Then
If StringContainsAny(TEXT, Array(280, 281)) Then
GHS4 = "Picture 4, "
End If
End If
End If
If StringContainsAny(TEXT, Array(334)) Then
GHS8 = "Picture 8, "
GESUNDHEITSSCHAEDLICH = True ' HARMFUL
End If
If StringContainsAny(TEXT, Array(290, 314, 318)) Then
GHS5 = "Picture 5, "
AETZEND = True ' CORROSIVE
End If
If StringContainsAny(TEXT, Array(304, 340, 341, 350, 351, 360, 361, 370, 371, 372, 373)) Then
GHS8 = "Picture 8, "
End If
If GIFTIG = False Then
If StringContainsAny(TEXT, Array(302, 312, 332)) Then
GHS7 = "Picture 7, "
End If
If AETZEND = False Then
If GESUNDHEITSSCHAEDLICH = False Then
If StringContainsAny(TEXT, Array(315, 319)) Then
GHS7 = "Picture 7, "
End If
End If
End If
If GESUNDHEITSSCHAEDLICH = False Then
If StringContainsAny(TEXT, Array(317)) Then
GHS7 = "Picture 7, "
End If
End If
If StringContainsAny(TEXT, Array(335, 336, 420)) Then
GHS7 = "Picture 7, "
End If
End If
If StringContainsAny(TEXT, Array(400, 410, 411)) Then
GHS9 = "Picture 9, "
End If
' GWteB
' yet another use of worksheet reference oWs
oWs.Range(GHS_NUMMERN & ZEILE) = oWs.Range(GHS_NUMMERN & ZEILE) & GHS1 & GHS2 & GHS3 & GHS4 & GHS5 & GHS6 & GHS7 & GHS8 & GHS9 ' GHS_NUMBERS & ROW)
End If
Next COLUMN
Next ZEILE
For ZEILE = ZEILE_ANFANG To ZEILE_ENDE 'Jede Zeile wird überprüft --- Every line is checked
' GWteB
' yet another use of worksheet reference oWs
TEXT = oWs.Range(GHS_NUMMERN & ZEILE)
ZAEHLER = 0
For FELD = 1 To 9 'Jedes Gefahrensymbol wird gesucht --- Every danger symbol is searched for
BEZEICHNUNG = "Picture " & CStr(FELD) '"GHS0?" ' DESCRIPTION
If InStr(TEXT, BEZEICHNUNG) Then
ThisWorkbook.Worksheets("Pictograms").Shapes(BEZEICHNUNG).Copy
Dim shpJustPasted As Picture
Dim ErrorNumber As Long
Dim MaxAttempts As Long
Dim Attempts As Long
Dim MsgAnswer As VbMsgBoxResult
' ------------------------------------------------------------------------
' GWteB: Prevent some mysterious, not consistent behavior:
' VBA randomly throws a run-time error on the Worksheet.Paste method
SUB_Retry:
MaxAttempts = 3 ' <<<<< change maximum amount of attempts to suit
Attempts = 0
ErrorNumber = -1
MsgAnswer = vbOK
Do Until Attempts = MaxAttempts
On Error Resume Next
oWs.Paste oWs.Range(GHS_SYMBOLE & ZEILE)
ErrorNumber = Err.Number
Err.Clear
On Error GoTo 0
If Not CBool(ErrorNumber) Then
Exit Do
Else
Attempts = Attempts + 1
End If
Loop
If CBool(ErrorNumber) Then
MsgAnswer = MsgBox("Error on pasting pictures, maximum amount of attempts has been reached.", vbExclamation + vbRetryCancel, "Gefahrstoffsymbol")
End If
If MsgAnswer = vbRetry Then GoTo SUB_Retry
If MsgAnswer = vbCancel Then GoTo SUB_Cancel
' -------------------------------------------------------------------------
Set shpJustPasted = oWs.Pictures(oWs.Pictures.Count)
With shpJustPasted
.Name = BEZEICHNUNG
.Locked = False
.ShapeRange.LockAspectRatio = msoFalse
.Height = HOEHE
.Width = HOEHE
.Top = oWs.Range(GHS_SYMBOLE & ZEILE).Top + 1
.Left = oWs.Range(GHS_SYMBOLE & ZEILE).Left + ZAEHLER + 1 ' COUNTER
.Placement = xlMove
End With
ZAEHLER = ZAEHLER + HOEHE
End If
Next
Next
oWs.Range(GHS_SYMBOLE & ZEILE_ANFANG & ":" & GHS_SYMBOLE & ZEILE_ENDE).Rows.EntireRow.AutoFit
SUB_Cancel:
' GWteB
' reposition Excel's selector where it initial came from
ActCell.Activate
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
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
.
