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