XL 2013 Importation d'un classeur fermé et classement

Option Explicit
Public derlig As Long

Sub Importer()
Dim wkSource As Workbook, wkDest As Workbook, ShA As Worksheet, ShB As Worksheet
Dim shC As Worksheet, Fichier As String

    Application.ScreenUpdating = False

    Fichier = ThisWorkbook.Path & "\INVENTAIRES.xlsx"

    Set wkSource = Workbooks.Open(Fichier)
    Set wkDest = ThisWorkbook
    Set ShA = ActiveWorkbook.Sheets("INV")
    Set ShB = wkDest.Sheets("BD ARTICLES")
    Set shC = wkDest.Sheets(3)


    derlig = shC.Range("f" & Rows.Count).End(xlUp).Row


    With ShA
        derlig = .Range("b" & Rows.Count).End(xlUp).Row
        .Range("b24:e" & derlig).Copy ShB.Range("b7")
        .Range("b24:b" & derlig).Copy shC.Range("b7")
        .Range("f24:f" & derlig).Copy shC.Range("d7")
        .Range("h24:h" & derlig).Copy shC.Range("e7")
    End With
    ActiveWorkbook.Close False




  With ShB
          derlig = .Range("b" & Rows.Count).End(xlUp).Row
          .Range(.Cells(7, "A"), .Cells(derlig, "A")).FormulaR1C1 = "=LEFT(RC[1],2)&LEFT(RC[2],2)&""-000"" &ROW()-6"
          .Range(.Cells(7, "A"), .Cells(derlig, "A")).Value = .Range(Cells(7, "A"), .Cells(derlig, "A")).Value
          If IsEmpty(.Range("b7:b" & derlig)) Then .Range("a7:a" & derlig).ClearContents
          .Range("a7:a" & derlig).Copy shC.Range("a7")
          Application.Goto .Range("a6")
  End With



    Application.DisplayAlerts = False
    ThisWorkbook.Save
End Sub

Option Explicit
Public derlig As Long

Sub Importer()
Dim wkSource As Workbook, wkDest As Workbook, ShA As Worksheet, ShB As Worksheet
Dim shC As Worksheet, Fichier As String

    Application.ScreenUpdating = False

    Fichier = ThisWorkbook.Path & "\INVENTAIRES.xlsx"

    Set wkSource = Workbooks.Open(Fichier)
    Set wkDest = ThisWorkbook
    Set ShA = ActiveWorkbook.Sheets("INV")
    Set ShB = wkDest.Sheets("BD ARTICLES")
    Set shC = wkDest.Sheets(3)


    derlig = shC.Range("f" & Rows.Count).End(xlUp).Row


    With ShA
        derlig = .Range("b" & Rows.Count).End(xlUp).Row
        .Range("b24:e" & derlig).Copy ShB.Range("b7")
        .Range("b24:b" & derlig).Copy shC.Range("b7")
        .Range("f24:f" & derlig).Copy shC.Range("d7")
        .Range("h24:h" & derlig).Copy shC.Range("e7")
    End With
    shC.Range("e7:e" & derlig).Value = shC.Range("e7:e" & derlig).Value

    ActiveWorkbook.Close False

    Call Codes

    Application.DisplayAlerts = False
    ThisWorkbook.Save
End Sub

Public Sub Codes()
Dim tbl As Range, ShB As Worksheet
Set Coll_Str = New Collection


Set ShB = Sheets("BD ARTICLES")

With ShB
DerLgn = .Cells(.Rows.Count, 2).End(xlUp).Row
DerCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
Tablo = .Range(.Cells(7, 1), .Cells(DerLgn, DerCol)).Value
ReDim Tab_Ref(UBound(Tablo, 1), 1)
On Error Resume Next
For L = 1 To UBound(Tablo, 1)
Str_Search = IIf(Tablo(L, 3) <> "", Left(Tablo(L, 2), 2) & Left(Tablo(L, 3), 2), "")
    Coll_Str.Add Str_Search, CStr(Str_Search)
If Err.Number = 0 Then
x = 1
For LL = 1 To UBound(Tablo, 1)
   Str_Compare = Left(Tablo(LL, 2), 2) & Left(Tablo(LL, 3), 2)
   If Str_Compare Like Str_Search Then
      Tab_Ref(LL, 1) = Str_Compare & Format(x, "-0000")
        x = x + 1
   End If
Next LL
End If
Err.Clear
Next L
      .Range("A7").Resize(UBound(Tab_Ref, 1), 1) = Tab_Ref
End With
Set Tablo = Nothing: Set Coll_Str = Nothing
End Sub

Option Explicit
Option Base 1
Dim Tablo As Variant
Dim Tab_Ref() As Variant
Dim DerLgn As Long
Dim DerCol As Byte
Dim I As Long
Dim L As Long
Dim LL As Long
Dim x As Long
Dim Coll_Str As Collection
Dim Str_Search As String
Dim Str_Compare As String

Public Sub Test()

Set Coll_Str = New Collection
I = 1
With Worksheets("Feuil1")
DerLgn = .Cells(.Rows.Count, 2).End(xlUp).Row 'on definit la derniere ligne non vide de la plage de  donnees a partir de la colonne "B"
DerCol = .Cells(6, .Columns.Count).End(xlToLeft).Column 'on definit la derniere Colonne non vide de la plage de  donnees a partir de la Ligne "6"
 Tablo = .Range(.Cells(7, 1), .Cells(DerLgn, DerCol)).Value 'on récupére les donnees de la plage ainsi définie
ReDim Tab_Ref(UBound(Tablo, 1), 1) 'on rédimensionne le tableau des Références x Lignes , Une Colonne
On Error Resume Next 'gestion des erreurs eventuelles
For L = I To UBound(Tablo, 1) 'pour chaque ligne du tableau des donnees
 Str_Search = IIf(Tablo(L, 3) <> "", Left(Tablo(L, 2), 2) & Left(Tablo(L, 3), 2), "") 'on récupére si la Colonne 3 n'est pas vide les deux premiers caracteres des Colonne "B"(2) et "C"(3)
    Coll_Str.Add Str_Search, CStr(Str_Search) 'on entre la variable ainsi définie dans la Collection des références
 If Err.Number = 0 Then 'Si réference Non encore référencée
        x = 1 'on incremente la variable
 For LL = I To UBound(Tablo, 1)  'puis pour chaque ligne du tableau
   Str_Compare = Left(Tablo(LL, 2), 2) & Left(Tablo(LL, 3), 2) 'on va récupérer les deux premiers caracteres des Colonne "B"(2) et "C"(3)
   If Str_Compare Like Str_Search Then 'on compare les deux variables si Ok
      Tab_Ref(LL, 1) = Str_Compare & Format(x, "-0000") 'Récupére dans le tableau des références la Variable formatee
        x = x + 1: I = I + 1: L = I  'on incremente les Variables
   End If
 Next LL
 End If
Err.Clear 'on efface l'erreur eventuelle
Next L
      .Range("A7").Resize(UBound(Tab_Ref, 1), 1) = Tab_Ref 'on colle dans la premiere colonne le tableau des références
End With
Set Tablo = Nothing: Set Coll_Str = Nothing 'on vide les variables
End Sub

Str_Compare =Ucase( Left(Tablo(LL, 2), 2) & Left(Tablo(LL, 3), 2)

Str_Compare = Left(Tablo(LL, 2), 2) & Left(Tablo(LL, 3), 2)