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 110 111 112 113
| Dim l As Integer
Dim Moy As Double
Dim t0 As Double
Dim N As Double, R As Double, Multipl As Double
Sub glo2parties()
Application.ScreenUpdating = False
Call PointsFaux
Call text
Application.ScreenUpdating = True
End Sub
Sub PointsFaux()
DerCell_1 = Worksheets(1).Range("A1").End(xlDown).Row
DerCell_2 = Worksheets(2).Range("A1").End(xlDown).Row
Moy = Application.Average(Worksheets("Feuil1").Range("D2:D" & DerCell_1), Worksheets("Feuil2").Range("D2:D" & DerCell_2))
t0 = Worksheets("Feuil1").Range("E1")
N = 0.158
w = WorksheetFunction.Pi * N / 30
R = 400.38
Multipl = w * R
l = 1
SupFaux Worksheets("Feuil1")
l = 2
SupFaux Worksheets("Feuil2")
End Sub
Private Sub SupFaux(Ws As Worksheet)
Dim DeltaX As Double, DeltaZ As Double, Ang As Double
Dim LastLig As Long, i As Long, j As Long, k As Long
Dim Passe As Boolean
Dim m As Byte
Dim Tb, Res()
Application.ScreenUpdating = False
With Ws
.Select
LastLig = .Rows.Count
Tb = .Range("A1:E" & LastLig)
ReDim Res(1 To LastLig, 1 To 5)
j = 1
For i = 1 To LastLig
If i > 2 Then
If Tb(i, 1) = "" Then Exit For
If Tb(i, 4) < Moy Then
Passe = True
Else
If Tb(i, 1) > Tb(i - 1, 1) Then
DeltaX = Tb(i, 3) - Tb(j, 3)
DeltaZ = Tb(i, 4) - Tb(j, 4)
If DeltaX <> 0 And DeltaZ <> 0 Then Ang = Application.WorksheetFunction.Atan2(Abs(DeltaX), Abs(DeltaZ))
If Abs(Ang) > 0.87 Then Passe = True
End If
End If
End If
If Not Passe Then
j = i
k = k + 1
For m = 3 To 5
Res(k, m - 2) = Tb(i, m)
Next m
Res(k, 3) = (Res(k, 3) - t0) / 10000 * Multipl
Else
Passe = False
End If
Next i
If Tb(1048576, 1) <> "" Then
DerCell = 1048576
Else: DerCell = .Range("A1").End(xlDown).Row
End If
End With
Worksheets.Add.Select
ActiveSheet.Name = "Result" & l
ActiveSheet.Range("A1:E" & k) = Res
End Sub
Sub remplissage()
Dim col As Integer
Dim Val As Double, Multipl As Double
Dim Zone As Range
Dim N As Double, w As Double, R As Double
rempl Worksheets("Result1")
rempl Worksheets("Result2")
End Sub
Sub text()
With ThisWorkbook
Nom1 = Mid(.Name, 1, InStrRev(.Name, ".") - 1) & "_1" & ".txt"
Nom2 = Mid(.Name, 1, InStrRev(.Name, ".") - 1) & "_2" & ".txt"
Nom3 = Mid(.Name, 1, InStrRev(.Name, ".") - 1) & ".txt"
End With
Sheets("Result1").Select
ActiveWorkbook.SaveAs Filename:="M:\Fichiers profils\" & Nom1, FileFormat:=xlText, CreateBackup:=False
Sheets("Result2").Select
ActiveWorkbook.SaveAs Filename:="M:\Fichiers profils\" & Nom2, FileFormat:=xlText, CreateBackup:=False
Shell ("cmd /c copy M:\Fichiers profils\*.txt M:\Fichiers profils\Fichier.txt")
End Sub |
Partager