Discussion :

[lps02]

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

[lps02]

Re-bonsoir

En fait quand j'ouvre plusieurs fichiers, il semble qu'il y ait un décalage d'une ligne vers le haut dans les cellules où devraient se faire les calculs (résultats sur la ligne d'avant). Celà ne se fait pas si j'ouvre fichier par fichier.

une explication?

le code faisant les conditions "ID"; "IT"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
'Conditions pour ID IT
        .Cells(j, 6).Value = IIf(.Cells(i, 5).Value <> "", IIf(.Cells(i, 5).Value < 90, "ID", "IT"), "")

bonsoir à vous

Aprés recherche, le problème semble être le suivant : pour les conditions "ID" IT, le calcul se fait toujours sur la base de la première feuille ouverte(le calcul est Correct dans la première feuille).
On dirait qu'il y a alors copie des cellules de la première feuille dans les suivantes .

Exemple, si dans la première feuille, il y a un ID dans la deuxième ligne et un It dans la cinquième, dans la feuille suivante, il y a copie de Id dans la deuxième ligne et IT dans la cinquième.

A votre avis de quoi cela peut il venir?? Pouvez vous m'aider SVP???

Cordialement

lps02
Les codes sont donnés plus haut.

[lps02]

bonsoir à vous

Après recherche, le problème semble être le suivant : pour les conditions "ID" IT, le calcul se fait toujours sur la base de la première feuille ouverte(le calcul est Correct dans la première feuille).
On dirait qu'il y a alors copie des cellules de la première feuille dans les suivantes .

Exemple, si dans la première feuille, il y a un ID dans la deuxième ligne et un It dans la cinquième, dans la feuille suivante, il y a copie de Id dans la deuxième ligne et IT dans la cinquième.

A votre avis de quoi cela peut il venir?? Pouvez vous m'aider SVP???

Cordialement

lps02
Les codes sont donnés plus haut.

[gFZT82]

Bonjour,

Tu as tout intérêt à préciser le classeur auquel tu fais référence
A priori,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
'Conditions pour ID IT 
.Cells(j, 6).Value = IIf(Sh.Cells(i, 5).Value <> "", IIf(Sh.Cells(i, 5).Value < 90, "ID", "IT"), "") 
'calcul pieces
 .Cells(j, 11).Value = IIf(Sh.Cells(i, 6).Value = "ID", 0, 1) 
'Calcul mesures 
.Cells(j, 12).Value = IIf(Sh.Cells(i, 8).Value <> 0, 1, 0) 
'Calcul grumes
 .Cells(j, 13).Value = IIf(Sh.Cells(i, 6).Value = "", 1, 0)

Cordialement.

[lps02]

Bonjour

en fait, il ne faut pas faire allusion à la feuille mais il fallait mette j au lieu de i

voir le code suivant. ta réponse m'a toutefois mis sur la voie

Encore un grand merci. de même pour les autres calculs.

Vous êtes vraiment très fort

Bien cordialement
lps02

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 'Conditions pour ID IT
        .Cells(j, 6).Value = IIf(.Cells(j, 5).Value <> "", IIf(.Cells(j, 5).Value < 90, "ID", "IT"), "")