Bonjour à vous les maîtres de VBA

Mon problème:
Je transfère des données depuis des feuilles de saisies terrain sous excel dans une base de donnée.
Lorsque je fais les ouvertures de chaque feuille une à une tous les calculs se passent bien.

par contre quand j'ouvre plusieurs dossiers, les calculs de "ID" "IT" ne fonctionnent pas (les valeurs se mettent sur les mauvaises lignes.

Pouvez vous m'aider?

Voici mon code (réalisé grâce à votre aide )
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
Sub OuvertureDeFichiers()
Dim i As Byte, Rep As Byte, n As Byte
Dim OuvrirFichiers As Variant
Dim Liste As String
Dim Wbk As Workbook
 
Application.ScreenUpdating = False
ChDir ("C:\Documents and Settings\Portable COFA\Mes documents\aide excel\ESSAI BOIS ABATTU\donnes terrain\")
OuvrirFichiers = Application.GetOpenFilename(Filefilter:="Fichiers texte(*.csv),*.csv,Fichiers excel(*.xls),*.xls", FilterIndex:=2, Title:="Ouverture de fichiers terrain", MultiSelect:=True)
 
If Not IsArray(OuvrirFichiers) Then
    MsgBox "Aucun Fichiers n' a été sélectionné. Fin de la procédure", vbOKOnly + vbInformation, "Fin de la procédure"
Else
    n = UBound(OuvrirFichiers)
    If n > 1 Then
        For i = 1 To n
            Liste = Liste & vbCr & OuvrirFichiers(i)
        Next i
        Rep = MsgBox("L'utilisateur a sélectionné plusieurs fichiers. En voici la liste." & Liste & vbCr & "Voulez-vous les ouvrir?", vbYesNo + vbQuestion, "Ouvrir les Fichiers?")
    End If
 
    If Rep <> vbNo Then
        For i = 1 To n
            Set Wbk = Workbooks.Open(Filename:=OuvrirFichiers(i))
 
            Transfert Wbk                        'Appel de la sub Transfert qui a comme parametre le fichier csv ouvert
 
            Wbk.Close False
            Set Wbk = Nothing
        Next i
    End If
End If
End Sub
 
Private Sub Transfert(ByVal Wb As Workbook)
Dim i As Long, j As Long
Dim Sh As Worksheet
 
Application.ScreenUpdating = False
i = 2
Set Sh = Wb.Worksheets(1)
With ThisWorkbook.Worksheets("Feuil1")
    j = .Cells(.Rows.Count, 1).End(xlUp).Row     'Ligne de dernière cellule remplie de colonne A
    While Sh.Cells(i, 1) <> ""
        j = j + 1
        .Cells(j, 4).Value = Sh.Cells(i, 1).Value
        .Cells(j, 4).TextToColumns Destination:=.Cells(j, 4), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
 
        'copie de l'essence
        .Cells(j, 3).Value = Sh.Cells(i, 2).Value
 
        'numerotation ordre
        .Cells(j, 1).Value = j - 1
 
        'recherche du code de l'essence
        .Cells(j, 2) = Application.WorksheetFunction.VLookup(Sh.Cells(i, 2).Value, ThisWorkbook.Worksheets("qualite").Range("$D$2:$E$28"), 1)
 
        'import longueur
        .Cells(j, 7).Value = Sh.Cells(i, 3).Value
 
        'Operation sur diametre en m
        .Cells(j, 8).Value = Sh.Cells(i, 5).Value / 100
 
        'Conditions pour ID IT
        .Cells(j, 6).Value = IIf(.Cells(i, 5).Value <> "", IIf(.Cells(i, 5).Value < 90, "ID", "IT"), "")
 
        'reduction longueur en m
        .Cells(j, 9).Value = IIf(Sh.Cells(i, 4).Value = 0, 0, Sh.Cells(i, 4).Value / 100)
 
        'Qualité
        .Cells(j, 10).Value = Application.WorksheetFunction.VLookup(Sh.Cells(i, 7).Value, ThisWorkbook.Worksheets("qualite").Range("$A$2:$B$12"), 2)
 
        'calcul pieces
        .Cells(j, 11).Value = IIf(.Cells(i, 6).Value = "ID", 0, 1)
 
        'Calcul mesures
        .Cells(j, 12).Value = IIf(.Cells(i, 8).Value <> 0, 1, 0)
 
        'Calcul grumes
        .Cells(j, 13).Value = IIf(.Cells(i, 6).Value = "", 1, 0)
 
        'Calcul volume net
        .Cells(j, 14).FormulaR1C1 = "=ROUND((RC[-7]-RC[-5])*RC[-6]*RC[-6]*PI()/4,3)"
 
        'Calcul volume brut
        .Cells(j, 15).FormulaR1C1 = "=ROUND(RC[-8]*RC[-7]*RC[-7]*PI()/4,3)"
 
        'Nom propriétaire
        .Cells(j, 17).Value = Sh.Range("A1").Value
 
        'Parcelle
        .Cells(j, 18).Value = Sh.Range("B1").Value
 
        'Lieu
        .Cells(j, 19).Value = Sh.Range("F1").Value
 
        'Date
        Sh.Range("C1").Copy
        With .Cells(j, 20)
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
            .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
        End With
        Application.CutCopyMode = False
        i = i + 1
    Wend
End With
Set Sh = Nothing
 
End Sub