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
| 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(j, 5).Value <> "", IIf(.Cells(j, 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(j, 6).Value = "ID", 0, 1)
'Calcul mesures
.Cells(j, 12).Value = IIf(.Cells(j, 8).Value <> 0, 1, 0)
'Calcul grumes
.Cells(j, 13).Value = IIf(.Cells(j, 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 |
Partager