Problème d'importation de toutes les cellules

Sub Importation()
    Dim chemin As String, fichier As String
    Dim Zdcl As Byte, Fdcl As Byte
    Dim plagezps As Range
    Dim Wbsource As Workbook, Ws As Worksheet

    chemin = ThisWorkbook.Path & Application.PathSeparator
    fichier = "ZPS.xlsx"
    Application.ScreenUpdating = False
    Workbooks.Open Filename:=chemin & fichier
    Set Wbsource = ActiveWorkbook
    Set Ws = Wbsource.Sheets("Forecast")

    With Ws
        Zdcl = .Cells(8, .Columns.Count).End(xlToLeft).Column    'dernire colonne fichier ZPS
        tbl = .UsedRange
    End With
    Wbsource.Close False
    With ThisWorkbook.Sheets("12-16")    'ActiveSheet
        entete = .[F9:Z9]

        For c = 7 To UBound(tbl, 2)
            For j = 1 To UBound(entete, 2)
                If tbl(8, c) = Left(entete(1, j), 3) & "-" & Right(entete(1, j), 2) Then 'compare mois et année
                    .Cells(13, j + 6) = tbl(12, c)
                    Exit For
                End If
            Next j
        Next c

        '    Fdcl = .Cells(9, .Columns.Count).End(xlToLeft).Column 'dernire colonne fichier ZPSforecast
        '    .Range("E10,E13,E15") = Ws.Range("E14")
        '    .Range("E18") = Ws.Range("E27")
        '    .Range("E20") = Ws.Range("E29")
        '    .Range("E22") = Ws.Range("E30")
        '    .Range("E25") = Ws.Range("E33")
        '    Union(.Cells(13, Fdcl), .Cells(15, Fdcl), .Cells(18, Fdcl)) = Ws.Cells(14, Zdcl)
        '    .Cells(20, Fdcl) = Ws.Cells(29, Zdcl)
        '    .Cells(22, Fdcl) = Ws.Cells(30, Zdcl)
        '
        '    Set plagezps = Ws.Range(Ws.Cells(8, 6), Ws.Cells(9, Zdcl))
        '    Dim zcol As Byte
        '    For i = 6 To Fdcl - 3
        '        On Error Resume Next
        '        zcol = plagezps.Find(Left(.Cells(9, i), 3) & "-" & Right(.Cells(9, i), 2), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Column
        '        If ThisWorkbook.Sheets(Sheets.Count) = 1 And i = 6 Then zcol = 6: Err = 0 'ajout ligne pour contourner Erreur sur Zcol si une seule feuille dans ZPSForecast lorsque i vaut 6
        '        If Err = 0 Then
        '        'If Left(ws.Cells(8, zcol), 4) = "Juil" Then zcol = zcol + 1
        '         If Left(.Cells(9, i), 4) = "Juil" Then zcol = zcol + 1
        '        .Cells(13, i) = Ws.Cells(14, zcol)
        '        .Cells(18, i) = Ws.Cells(27, zcol)
        '        .Cells(19, i) = .Cells(32, i)
        '        End If
        '        On Error GoTo 0
        '    Next i
    End With

    Workbooks("ZPS.xlsx").Close False
    Application.ScreenUpdating = True

End Sub

Public NomFeuil As String

Sub Importation()
    Dim chemin As String, fichier As String
    Dim Zdcl As Byte, Fdcl As Byte
    Dim plagezps As Range
    Dim Wbsource As Workbook, Ws As Worksheet

    chemin = ThisWorkbook.Path & Application.PathSeparator
    fichier = "ZPS.xlsx"
    Application.ScreenUpdating = False
    Workbooks.Open Filename:=chemin & fichier
    Set Wbsource = ActiveWorkbook
    Set Ws = Wbsource.Sheets("Forecast")
    NomFeuil = Feuil2.Name
    With Ws
        Zdcl = .Cells(8, .Columns.Count).End(xlToLeft).Column    'dernire colonne fichier ZPS
        tbl = .UsedRange
    End With
    Wbsource.Close False
    With ThisWorkbook.Sheets(NomFeuil)    'ActiveSheet
        entete = .[F9:Z9]
        For c = 7 To UBound(tbl, 2)
            For j = 1 To UBound(entete, 2)
                If tbl(8, c) = Left(entete(1, j), 3) & "-" & Right(entete(1, j), 2) Then    'compare mois et année
                    .Cells(13, j + 6) = tbl(12, c)
                    Exit For
                End If
            Next j
        Next c

    End With

    ChangeNomFeuil
    Application.ScreenUpdating = True

End Sub

Sub ChangeNomFeuil()
    Dim NouveauNom As String, g, d, pos As Byte

    pos = InStr(NomFeuil, "-")
    g = Mid(NomFeuil, 1, pos - 1): d = Mid(NomFeuil, pos + 1)
    If g = 12 Then
        d = d + 1
        NouveauNom = 1 & "-" & d
    Else
        g = g + 1
        NouveauNom = g & "-" & d
    End If

    Worksheets(NomFeuil).Name = NouveauNom

End Sub