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 |
