Macro copier plage avec condition textbox

r0man0

XLDnaute Nouveau
Bonjour,
J'ai un petit soucis j'ai une plage de données comprenant de 50 à 500 lignes, chaque lignes correspondant à un point de passage géoreférencé, comme des waypoints sur un gps, en faîtes j'aimerai pouvoir lui dire, (si il compte plus de 300 étapes), "comme la tu vas dépasser ta limite d'affichage, tu vas prendre toutes mes étapes du premier à celle que je vais t'indiquer dans une textbox et tu vas m'écrire mon fichier .rte, et tu vas prendre toutes mes étapes de celle que je t'ai indiqué à la dernière et tu vas m'écrire mon fichier .rte" voilà, grossomodo.
Sachant que dans ma plage j'ai une colonne "nom" qui correspond aux abréviations que j'utilise pour mes étapes, et que j'aimerai utiliser pour ma condition d'écriture.
J'ai trouvé une solution, mais ça ne fonctionne pas, bon je crois avoir fait des erreurs mais j'avoue que mes yeux et mon esprit fatigue un peu, je post le code,

Code:
Sub FICELLERTE()

Dim Destination, MaPlage, PL, R, DEST As Range
Dim Fs, U As Object
Dim FIC, ErrMsg, mot, PA As String
Dim K As Long
Dim Result, Choices, DL As Integer


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Work_Sheet_2").Select
Cells.ClearContents
Sheets("RTE_FLITESTAR").Select
Cells.ClearContents
Sheets("Compilation").Select
Set Destination = Sheets("Work_Sheet_2").Range("A1")
Set MaPlage = Sheets("Compilation").Range("A1:M" & Sheets("Compilation").Range("A65536").End(xlUp).Ro w)
Set tbl = ActiveCell.CurrentRegion


tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
MaPlage.Copy Destination

With Sheets("Work_Sheet_2")

Range("N1").FormulaR1C1 = "1"

Cells.Find("*", after:=[A1], LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, searchdirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False).Select

n = Selection.Row
mot = InputBox("Donnez code OACI")
DL = .Cells(Application.Rows.Count, 1).End(xlUp).Row
Set PL = .Range("T1:T" & DL)
Set R = PL.Find(mot, , xlValues, xlWhole)
End With

If Not R Is Nothing Then
PA = R.adress

With Sheets("RTE_FLITESTAR")
Set DEST = IIf(.Cells(1, 1) = "", .Cells(1, 1), .Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
End With

With Sheets("Work_Sheet_2")
If n > 299 Then
MsgBox ("Dépassement de la capacité de traitement ROUTE (>300)")
For compteur = 1 To PA
.Range("T1:T" & compteur).Value.Copy DEST
Next compteur
End If
End With

For i = 1 To n
Cells(i, 14).FormulaR1C1 = _
"=R[-1]C+1"
Cells(i, 15).FormulaR1C1 = _
"=RC[-9]+((500*RC[-8]+3*RC[-7])/30000)"
Cells(i, 17).FormulaR1C1 = _
"=RC[-7]+((500*RC[-6]+3*RC[-5])/30000)"
Cells(i, 16).FormulaR1C1 = _
"=IF(RC[-11]=""s"",-RC[-1],RC[-1])"
Cells(i, 18).FormulaR1C1 = _
"=IF(RC[-9]=""W"",-RC[-1],RC[-1])"
Cells(i, 20).FormulaR1C1 = _
"=CONCATENATE(""W, 0, "",C[-6],"", "",C[-6],"","",C[-16],"" , "",C[-4],"", "",C[-2],"",39154.4176025, 111, 4, 5, 255, 13158342,0, 0, 0"")"
Next i

Range("T1:T65000").Copy

Sheets("RTE_FLITESTAR").Columns("A:A").PasteSpecia l Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Sheets("RTE_FLITESTAR").Select
For j = 1 To 5
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next j

Range("A1").FormulaR1C1 = "OziExplorer Route File Version 1.0"
Range("A2").FormulaR1C1 = "WGS 84"
Range("A3").FormulaR1C1 = "Reserved 1"
Range("A4").FormulaR1C1 = "Reserved 2"
Range("A5").FormulaR1C1 = "R, 0,R0 ,,255"

Set Fs = CreateObject("Scripting.FileSystemObject")
Set U = Fs.CreateTextFile("\\Etudes\public\03_MISSION\01_P REPARATION_MISSION\OUTIL ROUTE FLITESTAR\Route\RTE_FLITESTAR.rte", True)
With Sheets("RTE_FLITESTAR")
For K = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
On Error GoTo Errorhandler
U.WriteLine (.Range("A" & K).Value)
Next K

Errorhandler:

Select Case Err.Number

Case 13:
ErrMsg = "Une erreur est survenue ligne " & K - 5 & " de la feuille Compilation."

Result = MsgBox(ErrMsg, Choices)

If Result = vbOK Then
Resume Next
End If
End Select
U.Close
Set U = Nothing
Set Fs = Nothing
NOM = InputBox("Donnez un nom de fichier.wpt")
If NOM = "" Then
Exit Sub
Else
GoTo continu
End If
continu:
FIC = Dir("\\Etudes\public\03_MISSION\01_PREPARATION_MIS SION\OUTIL ROUTE FLITESTAR\Route\RTE_FLITESTAR.rte")
If FIC <> "" Then Name "\\Etudes\public\03_MISSION\01_PREPARATION_MISSION \OUTIL ROUTE FLITESTAR\Route\" _
& FIC As "\\Etudes\public\03_MISSION\01_PREPARATION_MISSION \OUTIL ROUTE FLITESTAR\Route\" & NOM & ".rte"
End With
Sheets("Main_Sheet").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Export ROUTE réussi")
End If
End Sub

En faite, j'appel une fenêtre qui me demande de taper mon mot clé, elle le cherche, le trouve, l'identifie dans ma plage et lance une copie de la ligne 1 à la ligne contenant mon mot clé gràce à mon compteur vers ma feuille RTE_FLITESTAR, et pareil de la ligne de mon mot clé à la dernière ligne.
Bon ça commence à devenir laborieux pour moi, je sèche complètement.

Merci.
 

Discussions similaires

Réponses
14
Affichages
621
Réponses
1
Affichages
122