Macros

MacroCheckNCopy.vba

Const PostEAC15 = "Suivi post VEAC15"
Const LotV6 = "Lots V6"
Const ARemplir = "A remplir"

' Sub pour copier plusieurs colonnes vers un autre onglet
' Après avoir vérifier la cohérence entre plusieurs versions
Sub MacroCheckNCopy()

    Dim i As Integer

    Dim idColumns(1 To 1) As Range
    'Set idColumns(1) = GetColumn(Worksheets(PostEAC15), "H", 3)
    Set idColumns(1) = GetColumn(Worksheets(LotV6), "B", 3)

    ' Récupérer la liste des ids dans les colonnes déclarées plus haut
    Dim ids() As String: ids = FetchUniqueValues(idColumns)

    ' Copie des valeurs pour chaque id
    Dim currentId As String
    Dim lastRow As Long: lastRow = 3
    For i = LBound(ids) To UBound(ids)
        currentId = ids(i)

        ' Ajouter une nouvelle ligne dans le tableau de destination
        Dim newRow As Range: Set newRow = Worksheets(ARemplir).Range("A:D").Rows(lastRow + 1).EntireRow
        lastRow = lastRow + 1

        Call AssignValues(newRow, currentId, idColumns)

    Next i

End Sub

Sub AssignValues(newRow As Range, currentId As String, idColumns() As Range)

    Dim tempValue As String, tempRange As Range, tempRanges() As Range, col As Integer, idx As Integer

    tempValue = vbNullString
    If InStr(currentId, "PS") Or InStr(currentId, "CCAG") Or InStr(currentId, "PIPS") Then
        tempValue = ConcatStr(" ; ", tempValue, "RPR")
    End If
    If InStr(currentId, "RCSL") Then
        tempValue = ConcatStr(" ; ", tempValue, "RGL")
    End If
    If InStr(currentId, "RIC") Then
        tempValue = ConcatStr(" ; ", tempValue, "RIC")
    End If
    If InStr(currentId, "RPN") Then
        tempValue = ConcatStr(" ; ", tempValue, "RPN")
    End If
    If InStr(currentId, "CCND") Then
        tempValue = ConcatStr(" ; ", tempValue, "KCL")
    End If
    If InStr(currentId, "RPI") Then
        tempValue = ConcatStr(" ; ", tempValue, "RGL/RPR")
    End If
    If InStr(currentId, "GEN") Then
        tempValue = ConcatStr(" ; ", "?", tempValue)
        GetRow(newRow, "B").Interior.Color = RGB(255, 255, 0)
    End If
    GetRow(newRow, "B").value = tempValue

    GetRow(newRow, "C").value = currentId

    GetRow(newRow, "D").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("C")).value

    GetRow(newRow, "E").value = vbNullString

    tempValue = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("D")).value
    If (tempValue = "Démarrage") Then
        GetRow(newRow, "F").value = "actée démarrage"
    ElseIf (tempValue = "Supprimée") Then
        GetRow(newRow, "F").value = "supprimée"
    ElseIf (tempValue = "Supprimée *") Then
        GetRow(newRow, "F").value = ""
    Else
        GetRow(newRow, "F").value = "cible VC1"
    End If

    GetRow(newRow, "G").value = vbNullString
    GetRow(newRow, "H").value = vbNullString

    tempValue = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("J")).value
    If (Trim(tempValue & vbNullString) <> vbNullString) Then
        GetRow(newRow, "I").value = tempValue
    Else
        tempValue = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("Q")).value
        If (tempValue = "1" Or tempValue = "2") Then
            GetRow(newRow, "I").value = "J5"
        End If
    End If

    GetRow(newRow, "J").value = vbNullString
    GetRow(newRow, "K").value = vbNullString

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "HW") <> 0 Then
        GetRow(newRow, "L").value = "O"
    Else
        Call SetWarningValue(newRow, "L", "N", tempRange)
    End If

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "SW") <> 0 Then
        GetRow(newRow, "M").value = "O"
    Else
        Call SetWarningValue(newRow, "M", "N", tempRange)
    End If

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "PIPS") <> 0 Then
        GetRow(newRow, "N").value = "O"
    Else
        Call SetWarningValue(newRow, "N", "N", tempRange)
    End If

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "paramétrage") <> 0 Then
        GetRow(newRow, "O").value = "O"
    Else
        Call SetWarningValue(newRow, "O", "N", tempRange)
    End If

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "SU") <> 0 Then
        GetRow(newRow, "P").value = "O"
    Else
        Call SetWarningValue(newRow, "P", "N", tempRange)
    End If

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "documentaire") <> 0 Then
        Call SetWarningValue(newRow, "Q", "?")
    Else
        Call SetWarningValue(newRow, "Q", "N", tempRange)
    End If

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "documentaire") <> 0 Then
        GetRow(newRow, "R").value = "O"
    Else
        Call SetWarningValue(newRow, "R", "N", tempRange)
    End If

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "T2000") <> 0 Then
        GetRow(newRow, "S").value = "O"
    Else
        Call SetWarningValue(newRow, "S", "N", tempRange)
    End If

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("E"))
    If InStr(tempRange.value, "IEG") <> 0 Then
        GetRow(newRow, "T").value = "O"
    Else
        Call SetWarningValue(newRow, "T", "N", tempRange)
    End If

    tempRanges = FetchUniqueRangeValues(currentId, idColumns, Worksheets(LotV6).columns("M"), Worksheets(LotV6).columns("N"))
    tempValue = vbNullString
    For idx = LBound(tempRanges) To UBound(tempRanges)
        tempValue = ConcatStr(vbNewLine, tempValue, tempRanges(idx).value)
    Next idx
    If tempValue <> vbNullString Then
        tempValue = "Oui." & vbNewLine & tempValue
    ElseIf InStr(FetchValue(currentId, idColumns, Worksheets(LotV6).columns("L")).value, "non") = 1 Then
        tempValue = "Non"
    End If
    GetRow(newRow, "U").value = tempValue

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("P"))
    If Trim(tempRange.value & vbNullString) <> vbNullString Then
        GetRow(newRow, "V").value = "Oui." & vbNewLine & tempRange.value
    ElseIf InStr(FetchValue(currentId, idColumns, Worksheets(LotV6).columns("O")).value, "non") = 1 Then
        GetRow(newRow, "V").value = "Non"
    End If

    GetRow(newRow, "W").value = vbNullString
    GetRow(newRow, "X").Interior.Color = RGB(255, 255, 0)
    GetRow(newRow, "Y").value = vbNullString
    GetRow(newRow, "Z").value = vbNullString

    Set tempRange = FetchValue(currentId, idColumns, Worksheets(LotV6).Range("A:BC"))
    Dim columnCount As Integer: columnCount = LastCol(Worksheets(LotV6))
    For idx = 1 To columnCount
        If InStr(tempRange.Cells(idx).value, "CTE") Or InStr(tempRange.Cells(idx).value, "FTE") Then
            Call SetWarningValue(newRow, "AA", "?", tempRange.Cells(idx))
        End If
    Next idx

    tempValue = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("A")).value
    If InStr(tempValue, "CANP") <> 0 Then
        Call SetWarningValue(newRow, "AB", "à remplir, voir colonne FDM/DDM")
    End If

    tempValue = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("A")).value
    GetRow(newRow, "AC").value = tempValue
    If InStr(tempValue, "CANP") <> 0 Then
        GetRow(newRow, "AC").Interior.Color = RGB(255, 255, 0)
    End If

    GetRow(newRow, "AD").value = vbNullString
    GetRow(newRow, "AE").value = vbNullString
    GetRow(newRow, "AF").value = vbNullString
    GetRow(newRow, "AG").value = vbNullString
    GetRow(newRow, "AH").value = vbNullString
    GetRow(newRow, "AI").value = vbNullString

    GetRow(newRow, "AJ").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("Q")).value
    GetRow(newRow, "AK").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("R")).value
    GetRow(newRow, "AL").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("S")).value
    GetRow(newRow, "AM").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("T")).value
    GetRow(newRow, "AN").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("U")).value
    GetRow(newRow, "AO").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("V")).value
    GetRow(newRow, "AP").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("W")).value
    GetRow(newRow, "AQ").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("X")).value
    GetRow(newRow, "AR").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("Y")).value
    GetRow(newRow, "AS").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("Z")).value
    GetRow(newRow, "AT").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("AA")).value
    GetRow(newRow, "AU").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("AB")).value
    GetRow(newRow, "AV").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("AC")).value
    GetRow(newRow, "AW").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("AD")).value
    GetRow(newRow, "AX").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("AE")).value
    GetRow(newRow, "AY").value = vbNullString
    GetRow(newRow, "AZ").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("F")).value
    GetRow(newRow, "BA").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("G")).value
    GetRow(newRow, "BB").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("H")).value
    GetRow(newRow, "BC").value = FetchValue(currentId, idColumns, Worksheets(LotV6).columns("I")).value

End Sub

Sub SetWarningValue(newRow As Range, column As String, value As String, Optional row As Range = Nothing)
    GetRow(newRow, column).value = value
    GetRow(newRow, column).Interior.Color = RGB(255, 255, 0)

    If Not row Is Nothing Then
        Call AddComment(GetRow(newRow, column), DisplayRange(row))
    End If
End Sub

Function GetRow(row As Range, column As String) As Range
    Set GetRow = row.columns(row.Worksheet.Range(column & ":" & column).column)
End Function

' Récupération de valeurs unique dans un ensemble de colonnes
' @param columns Ensemble de colonnes où il faut récupérer le contenu des lignes
' @return String() Ensemble des valeurs uniques
Function FetchUniqueValues(ByRef columns() As Range) As String()

    Dim uniqueValues() As String
    Dim i As Integer, j As Integer

    ' Index où ajouter une nouvelle valeur
    Dim idx As Integer: idx = 0

    Dim column As Range
    For i = LBound(columns) To UBound(columns)
        Set column = columns(i)

        ' Préparer le tableau des valeurs pour ajouter les nouvelles valeurs
        ReDim Preserve uniqueValues(column.Count + idx - 1)

        For j = 1 To column.Count
            uniqueValues(idx) = column.Cells(j).value
            idx = idx + 1
        Next j

    Next i

    FetchUniqueValues = RemoveDuplicates(uniqueValues)

End Function

' Prend un tableau de plusieurs valeurs et supprime les doublons
' @param Array_1 Liste des valeurs à nettoyer
' @return String() Liste des valeurs nettoyées
Function RemoveDuplicates(Array_1() As String) As String()

    If IsVarArrayEmpty(Array_1) Then
        RemoveDuplicates = Array_1
        Exit Function
    End If

    Dim Array_2() As String, eleArr_1 As String, x As Integer, i As Integer
    x = 0
    i = 0
    For i = LBound(Array_1) To UBound(Array_1)
        eleArr_1 = Array_1(i)
        If Not IsInArray(eleArr_1, Array_2) Then
            ReDim Preserve Array_2(x)
            Array_2(x) = eleArr_1
            x = x + 1
        End If
    Next i

    RemoveDuplicates = Array_2

End Function

' Récupère des valeurs dans un ensemble de colonnes en fonction d'un id dans une colonne spécifique
' @param currentId Identifiant à trouver dans le 2ème paramètre pour trouver la ligne des valeurs à récupérer
' @param idColumns Liste des colonnes où on peut trouver le 1er paramètre et qui déterminera la ligne des valeurs à récupérer
' @param sources Ensemble des colonnes où les valeurs à récupérer sont présentes
' @return
Function FetchUniqueRangeValues(currentId As String, idColumns() As Range, ParamArray sources() As Variant) As Range()

    Dim values() As Range
    Dim i As Integer, j As Integer

    Dim idx As Integer: idx = 0

    Dim idColumn As Range, idRow As Range, source As Range
    For i = LBound(idColumns) To UBound(idColumns)
        Set idColumn = idColumns(i)
        Set idRow = idColumn.Find(currentId)
        If Not idRow Is Nothing Then
            For j = LBound(sources) To UBound(sources)
                Set source = sources(j)
                If source.Parent.Index = idRow.Parent.Index And Trim(source.Rows(idRow.row).value & vbNullString) <> vbNullString Then
                    ReDim Preserve values(idx)
                    Set values(idx) = source.Rows(idRow.row)
                    idx = idx + 1
                End If
            Next j
        End If
    Next i

    FetchUniqueRangeValues = RemoveRangeDuplicates(values)

End Function

Function FetchValue(currentId As String, idColumns() As Range, source As Range) As Range

    Dim i As Integer

    Dim idColumn As Range, idRow As Range
    For i = LBound(idColumns) To UBound(idColumns)
        Set idColumn = idColumns(i)
        Set idRow = idColumn.Find(currentId)
        If Not idRow Is Nothing Then
            If source.Parent.Index = idRow.Parent.Index Then
                Set FetchValue = source.Rows(idRow.row)
                Exit Function
            End If
        End If
    Next i

    FetchValue = Nothing

End Function

' Prend un tableau de plusieurs valeurs et supprime les doublons
' @param Array_1 Liste des valeurs à nettoyer
' @return String() Liste des valeurs nettoyées
Function RemoveRangeDuplicates(Array_1() As Range) As Range()

    If IsVarArrayEmpty(Array_1) Then
        RemoveRangeDuplicates = Array_1
        Exit Function
    End If

    Dim Array_2() As Range, eleArr_1 As Range, x As Integer, i As Integer
    x = 0
    i = 0
    For i = LBound(Array_1) To UBound(Array_1)
        Set eleArr_1 = Array_1(i)
        If Not IsInRangeArray(eleArr_1, Array_2) Then
            ReDim Preserve Array_2(x)
            Set Array_2(x) = eleArr_1
            x = x + 1
        End If
    Next i

    RemoveRangeDuplicates = Array_2

End Function

Function ConcatStr(separator As String, ParamArray values() As Variant) As String

    ConcatStr = vbNullString

    Dim i As Integer
    For i = LBound(values) To UBound(values)

        ConcatStr = ConcatStrValue(separator, ConcatStr, values(i))

    Next i

End Function

Function ConcatStrValue(separator As String, str As String, value As Variant) As String

    If TypeOf value Is Range Then

        If (Trim(value.value & vbNullString) <> vbNullString) Then
            If str <> vbNullString Then
                str = str & separator
            End If
            str = str & DisplayRange(value)
        End If

    ElseIf InStr(1, TypeName(value), "(") > 0 Then 'array

        Dim i As Integer
        For i = LBound(value) To UBound(value)

            str = ConcatStrValue(separator, str, value(i))

        Next i

    Else

        If (Trim(CStr(value) & vbNullString) <> vbNullString) Then
            If str <> vbNullString Then
                str = str & separator
            End If
            str = str & CStr(value)
        End If

    End If

    ConcatStrValue = str

End Function

Function DisplayRange(ByVal value As Range) As String

    DisplayRange = value.Parent.Name & " :: " & value.Address(False, False) & ": " & value.value

End Function

Sub AddComment(rg As Range, text As String)

    Dim shCmt As Comment
    On Error Resume Next

    Set shCmt = rg.Comment
    On Error GoTo 0

    If shCmt Is Nothing Then
        Set shCmt = rg.AddComment
    ElseIf shCmt.text <> "" Then
        text = shCmt.text & vbNewLine & text
    End If

    shCmt.text text:=text

End Sub

Function IsVarArrayEmpty(anArray As Variant) As Boolean

    Dim i As Integer

    On Error Resume Next
        i = UBound(anArray, 1)
    If Err.Number = 0 And i <> -1 Then
        IsVarArrayEmpty = False
    Else
        IsVarArrayEmpty = True
    End If

End Function

Function GetColumn(ws As Worksheet, column As String, Optional start As Long = 1) As Range

    Dim last As Long: last = ws.Cells(ws.Rows.Count, column).End(xlUp).row
    Set GetColumn = ws.Range(column & start & ":" & column & last)

End Function

Function IsInArray(stringToBeFound As String, arr() As String) As Boolean

    If IsVarArrayEmpty(arr) Then
        IsInArray = False
        Exit Function
    End If

    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)

End Function

Function IsInRangeArray(rangeToBeFound As Range, arr() As Range) As Boolean

    If IsVarArrayEmpty(arr) Then
        IsInRangeArray = False
        Exit Function
    End If

    Dim i As Integer
    For i = LBound(arr) To UBound(arr)
        If arr(i).text = rangeToBeFound.text Then
            IsInRangeArray = True
            Exit Function
        End If
    Next i

    IsInRangeArray = False

End Function

Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).column
    On Error GoTo 0
End Function

MacroIncrement.vba

' Simple Sub pour faciliter l'appel via bouton
Sub MacroIncrement()

    ' Colonne où sont situés les identifiants
    Dim idColumn As String
    idColumn = "B"

    ' Prefix à utiliser
    Dim prefix As String
    prefix = GetPrefix()

    ' Calculer, proposer et si besoin, ajouter
    Call IncrementPrefix(idColumn, prefix)

End Sub

' Function pour demander à l'utilisateur quel prefix il veut utiliser
Function GetPrefix() As String

    GetPrefix = "PS"

End Function

' Sub pour calculer le max du prefix dans la colonne demandée et demander pour ajouter
Sub IncrementPrefix(idColumn As String, prefix As String)

    ' Choix du prefix à utiliser (ex "PS" pour identifiant "PS-125")
    prefix = GetPrefix()

    Dim delim As String
    delim = "-"

    ' Pour des raisons de vitesse (et pour savoir où ajouter la nouvelle ligne)
    ' On va chercher le total de lignes
    Dim total As Integer
    total = Range(idColumn & Rows.Count).End(xlUp).row

    ' Cherche l'identifiant maximum (on enleve la ligne 1 qui sert d'entête-)
    myid = MaxID(prefix & delim, Range(idColumn & "2:" & idColumn & total))
    myid = myid + 1

    ' Générer le nouvel identifiant
    Dim newId As String
    newId = prefix & "-" & myid

    ' Proposer le nouvel identifiant
    If MsgBox("Prochain id dispo : " & newId, vbOKCancel, "Confirm") = vbOK Then
        ' Si oui alors on génère une nouvelle ligne
        Range(idColumn & (total + 1)).Value = prefix & delim & myid
    End If

End Sub

Function MaxID(prefix As String, searchRange As Range) As Integer

    Dim myid As Integer
    myid = 0

    Dim regEx As RegExp
    Set regEx = New RegExp
    regEx.Pattern = prefix & delim & "([0-9]+)"
    regEx.Global = False

    For Each cell In searchRange.Cells
        If regEx.Test(cell) Then
            myid = WorksheetFunction.max(myid, regEx.Execute(cell).Item(0).SubMatches.Item(0))
        End If
    Next cell

    MaxID = myid

End Function