Dim LaCol__AP() As String<code> Dim LesCasPourDateFutur(NbCasPossible) As String Dim MaxRienCas As Long Dim NbEnregistrementsLusàlafois As Long Dim intFic2 'je ne sais pas si byte, integer ou long donc je laisse excel choisir... Dim intFic10 'idem Dim RienL As Long '*******pour définir dans une autre Sub on a: intFic10 = FreeFile Open NomFichier10 For Input As intFic10 '******* Sub Lire1Enregistrement() On Error GoTo Erreur99 Do While Not EOF(intFic2) Input #intFic2, S_NbEnregistrementsLusàlafois NbEnregistrementsLusàlafois = Val(S_NbEnregistrementsLusàlafois) ReDim LaCol__AP(NbEnregistrementsLusàlafois) ReDim LaCol__AQ(NbEnregistrementsLusàlafois) 'sont des Integer ReDim LesCol__ARàCol__AZ(NbEnregistrementsLusàlafois, Col_BC - Col_AU + 1) 'Sont des Single ReDim LesCol__BBàCol__CS(NbEnregistrementsLusàlafois, Col_CV - Col_BE + 1) 'Sont des Byte 'NbEnregistrementsLusàlafois et MaxRienCas sont des Long car >37000 For RienL = 1 To NbEnregistrementsLusàlafois Input #intFic10, LaCol__AP(RienL) If PremièreRecherche Then For RienCas = 1 To MaxRienCas If LesCasPourDateFutur(RienCas) = LaCol__AP(RienL) Then CestTrouvé 'n'est qu'un affichage sur une feuille excel (pas fréquent) End If Next RienCas End If Next RienL Loop Exit Sub Erreur99: RienL = RienL 'pour juste mettre un point d'arret pour comprendre une éventuelle erreur Stop Resume End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionOption Explicit Option Base 1 Const col_A = 1: Const col_B = 2: Const Col_C = 3: Const Col_D = 4: Const Col_E = 5: Const Col_F = 6 Const col_G = 7: Const Col_H = 8: Const Col_I = 9: Const Col_J = 10: Const Col_K = 11: Const Col_L = 12 Const Col_M = 13: Const col_N = 14: Const Col_O = 15: Const Col_P = 16: Const Col_Q = 17: Const Col_R = 18 Const Col_S = 19: Const col_T = 20: Const Col_U = 21: Const Col_V = 22: Const Col_W = 23: Const Col_X = 24: Const Col_Y = 25 Const col_Z = 26: Const Col_AP = 26 + 16: Const Col_MS = 13 * 26 + 19 Dim NblT As Long Dim NomFich As String Dim NomFichier10 As String Dim NomFichier2 As String Dim Repertoire As String Dim intFic10 ' as ??? quel type pour un fichier?? Dim intFic2 Dim TraitementA As Byte Dim TraitementB As Byte Dim TraitementC As Byte Dim TraitementD As Byte Dim TraitementE As Byte Dim LaCol__AP() As String Dim LaCol__APSve() As String Dim LaCol__AP1() As String Dim LaCol__AP1Sve() As String Dim LaCol__AP2() As String Dim LaCol__AP2Sve() As String Dim LaCol__AP3() As String Dim LaCol__AP3Sve() As String Dim LaCol__AP4() As String Dim LaCol__AP4Sve() As String Dim LaCol__AP5() As String Dim LaCol__AP5Sve() As String Dim TempLaCol__AP() As String Dim RienC As Integer Dim RienL As Long Dim RienL1 As Long Dim NbLignes As Long Dim Longueur Dim rang As Byte Dim NouvChaine As String Sub OuvreLesFichiersPourEcrire() On Error Resume Next NomFich = "Calcul 3 " + " à la Date du " + _ str(Day(Date)) + "-" + str(Month(Date)) + "-" + str(Year(Date)) + "-" + str(Hour(Time)) + "H -" + str(Minute(Time)) + "Mn" NomFichier10 = "Les AP" + NomFich NomFichier2 = "NbLigneDeChaquePage " + NomFich Repertoire = "C:\Users\Claude\Documents\" ChDir Repertoire Close Kill NomFichier10 Kill NomFichier2 intFic10 = FreeFile Open NomFichier10 For Append As intFic10 ' Len = 89 intFic2 = FreeFile Open NomFichier2 For Append As intFic2 End Sub Sub FermeLesFichiers() Close End Sub Sub Initialisation() ' NbLignes est le nombre d'elements traités For RienL = 8 To 999999 If Worksheets("Les X - Y").Cells(RienL, Col_J) = Empty Then 'Worksheets("Les X - Y").Cells(RienL, Col_J) contient des dates de format "jj/mm/aaaa" NbLignes = RienL - 1 Exit For End If Next RienL ReDim LaCol__AP(1 To NbLignes) End Sub Sub Cinq_B5() Initialisation 'pour rendre indépendant de : Sub DebutPresentation() OuvreLesFichiersPourEcrire Traitement_B5A FermeLesFichiers MsgBox "Fini Ecrire" End Sub Sub Tableau_B5() Dim Rang1 As Byte Dim Rang3 As Byte ReDim LaCol__AP(1 To NbLignes) ReDim LaCol__AP1(1 To NbLignes) ReDim LaCol__AP2(1 To NbLignes) ReDim LaCol__AP3(1 To NbLignes) ReDim LaCol__AP4(1 To NbLignes) ReDim LaCol__AP5(1 To NbLignes) ReDim LaCol__AP1Sve(1 To NbLignes) ReDim LaCol__AP2Sve(1 To NbLignes) ReDim LaCol__AP3Sve(1 To NbLignes) ReDim LaCol__AP4Sve(1 To NbLignes) ReDim LaCol__AP5Sve(1 To NbLignes) ReDim LaCol__APSve(1 To NbLignes) With Worksheets("Les X - Y") 'Ici Source Rang1 = InStr(1, .Cells(22, Col_MS), "-") Rang3 = InStrRev(.Cells(22, Col_MS), "-", -1) Longueur = Len(.Cells(22, Col_MS)) For RienL = 22 To NbLignes LaCol__AP(RienL) = .Cells(RienL, Col_MS) LaCol__AP1(RienL) = Left(LaCol__AP(RienL), Rang1 - 1) LaCol__AP2(RienL) = Mid(LaCol__AP(RienL), Len(LaCol__AP1(RienL)) + 2, Len(LaCol__AP1(RienL))) LaCol__AP3(RienL) = Mid(LaCol__AP(RienL), 2 * Len(LaCol__AP1(RienL)) + 3, Len(LaCol__AP1(RienL))) LaCol__AP4(RienL) = Mid(LaCol__AP(RienL), 3 * Len(LaCol__AP1(RienL)) + 4, Len(LaCol__AP1(RienL))) LaCol__AP5(RienL) = Right(LaCol__AP(RienL), Longueur - Rang3) Next RienL End With LaCol__APSve = LaCol__AP LaCol__AP1Sve = LaCol__AP1 LaCol__AP2Sve = LaCol__AP2 LaCol__AP3Sve = LaCol__AP3 LaCol__AP4Sve = LaCol__AP4 LaCol__AP5Sve = LaCol__AP5 End Sub Sub Traitement_B5A() On Error GoTo Erreur1a Tableau_B5 For TraitementA = 0 To 7 '7 For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = LaCol__AP1Sve(RienL) Next RienL Select Case TraitementA Case 1 'cas 100 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = Left(LaCol__AP1(RienL), rang - 1) & NouvChaine & Right(LaCol__AP1(RienL), Len(LaCol__AP1(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5B Case 2 ' cas 010 rang = 3 NouvChaine = "**" For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = Left(LaCol__AP1(RienL), rang - 1) & NouvChaine & Right(LaCol__AP1(RienL), Len(LaCol__AP1(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5B Case 3 'cas 001 rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = Left(LaCol__AP1(RienL), rang - 1) & NouvChaine & Right(LaCol__AP1(RienL), Len(LaCol__AP1(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5B Case 4 ' cas 110 rang = 1 NouvChaine = "*/**" For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = Left(LaCol__AP1(RienL), rang - 1) & NouvChaine & Right(LaCol__AP1(RienL), Len(LaCol__AP1(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5B Case 5 'cas 011 rang = 3 NouvChaine = "**/*" For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = Left(LaCol__AP1(RienL), rang - 1) & NouvChaine & Right(LaCol__AP1(RienL), Len(LaCol__AP1(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5B Case 6 'cas 101 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = Left(LaCol__AP1(RienL), rang - 1) & NouvChaine & Right(LaCol__AP1(RienL), Len(LaCol__AP1(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = Left(LaCol__AP1(RienL), rang - 1) & NouvChaine & Right(LaCol__AP1(RienL), Len(LaCol__AP1(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5B Case 7 'cas 000 rang = 1 NouvChaine = "*/**/*/*" For RienL = 22 To UBound(LaCol__AP1) LaCol__AP1(RienL) = Left(LaCol__AP1(RienL), rang - 1) & NouvChaine & Right(LaCol__AP1(RienL), Len(LaCol__AP1(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5B Case 0 Traitement_B5B End Select Next TraitementA Exit Sub Erreur1a: RienL = RienL Stop: Resume End Sub Sub Traitement_B5B() ' Tableau_B5 ??? On Error GoTo Erreur1b For TraitementB = 0 To 7 '7 For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = LaCol__AP2Sve(RienL) Next RienL Select Case TraitementB Case 1 'cas 100 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = Left(LaCol__AP2(RienL), rang - 1) & NouvChaine & Right(LaCol__AP2(RienL), Len(LaCol__AP2(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5C Case 2 ' cas 010 rang = 3 NouvChaine = "**" For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = Left(LaCol__AP2(RienL), rang - 1) & NouvChaine & Right(LaCol__AP2(RienL), Len(LaCol__AP2(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5C Case 3 'cas 001 rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = Left(LaCol__AP2(RienL), rang - 1) & NouvChaine & Right(LaCol__AP2(RienL), Len(LaCol__AP2(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5C Case 4 ' cas 110 rang = 1 NouvChaine = "*/**" For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = Left(LaCol__AP2(RienL), rang - 1) & NouvChaine & Right(LaCol__AP2(RienL), Len(LaCol__AP2(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5C Case 5 'cas 011 rang = 3 NouvChaine = "**/*" For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = Left(LaCol__AP2(RienL), rang - 1) & NouvChaine & Right(LaCol__AP2(RienL), Len(LaCol__AP2(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5C Case 6 'cas 101 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = Left(LaCol__AP2(RienL), rang - 1) & NouvChaine & Right(LaCol__AP2(RienL), Len(LaCol__AP2(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = Left(LaCol__AP2(RienL), rang - 1) & NouvChaine & Right(LaCol__AP2(RienL), Len(LaCol__AP2(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5C Case 7 'cas 000 rang = 1 NouvChaine = "*/**/*/*" For RienL = 22 To UBound(LaCol__AP2) LaCol__AP2(RienL) = Left(LaCol__AP2(RienL), rang - 1) & NouvChaine & Right(LaCol__AP2(RienL), Len(LaCol__AP2(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5C Case 0 Traitement_B5C End Select ' Next TraitementB Exit Sub Erreur1b: RienL = RienL Stop: Resume End Sub Sub Traitement_B5C() On Error GoTo Erreur1c For TraitementC = 0 To 7 '7 For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = LaCol__AP3Sve(RienL) Next RienL Select Case TraitementC Case 1 'cas 100 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = Left(LaCol__AP3(RienL), rang - 1) & NouvChaine & Right(LaCol__AP3(RienL), Len(LaCol__AP3(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5D Case 2 ' cas 010 rang = 3 NouvChaine = "**" For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = Left(LaCol__AP3(RienL), rang - 1) & NouvChaine & Right(LaCol__AP3(RienL), Len(LaCol__AP3(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5D Case 3 'cas 001 rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = Left(LaCol__AP3(RienL), rang - 1) & NouvChaine & Right(LaCol__AP3(RienL), Len(LaCol__AP3(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5D Case 4 ' cas 110 rang = 1 NouvChaine = "*/**" For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = Left(LaCol__AP3(RienL), rang - 1) & NouvChaine & Right(LaCol__AP3(RienL), Len(LaCol__AP3(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5D Case 5 'cas 011 rang = 3 NouvChaine = "**/*" For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = Left(LaCol__AP3(RienL), rang - 1) & NouvChaine & Right(LaCol__AP3(RienL), Len(LaCol__AP3(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5D Case 6 'cas 101 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = Left(LaCol__AP3(RienL), rang - 1) & NouvChaine & Right(LaCol__AP3(RienL), Len(LaCol__AP3(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = Left(LaCol__AP3(RienL), rang - 1) & NouvChaine & Right(LaCol__AP3(RienL), Len(LaCol__AP3(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5D Case 7 'cas 000 rang = 1 NouvChaine = "*/**/*/*" For RienL = 22 To UBound(LaCol__AP3) LaCol__AP3(RienL) = Left(LaCol__AP3(RienL), rang - 1) & NouvChaine & Right(LaCol__AP3(RienL), Len(LaCol__AP3(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5D Case 0 Traitement_B5D End Select Next TraitementC Exit Sub Erreur1c: RienL = RienL Stop: Resume End Sub Sub Traitement_B5D() On Error GoTo Erreur1d For TraitementD = 0 To 7 '7 For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = LaCol__AP4Sve(RienL) Next RienL Select Case TraitementD Case 1 'cas 100 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = Left(LaCol__AP4(RienL), rang - 1) & NouvChaine & Right(LaCol__AP4(RienL), Len(LaCol__AP4(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5E Case 2 ' cas 010 rang = 3 NouvChaine = "**" For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = Left(LaCol__AP4(RienL), rang - 1) & NouvChaine & Right(LaCol__AP4(RienL), Len(LaCol__AP4(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5E Case 3 'cas 001 rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = Left(LaCol__AP4(RienL), rang - 1) & NouvChaine & Right(LaCol__AP4(RienL), Len(LaCol__AP4(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5E Case 4 ' cas 110 rang = 1 NouvChaine = "*/**" For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = Left(LaCol__AP4(RienL), rang - 1) & NouvChaine & Right(LaCol__AP4(RienL), Len(LaCol__AP4(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5E Case 5 'cas 011 rang = 3 NouvChaine = "**/*" For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = Left(LaCol__AP4(RienL), rang - 1) & NouvChaine & Right(LaCol__AP4(RienL), Len(LaCol__AP4(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5E Case 6 'cas 101 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = Left(LaCol__AP4(RienL), rang - 1) & NouvChaine & Right(LaCol__AP4(RienL), Len(LaCol__AP4(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = Left(LaCol__AP4(RienL), rang - 1) & NouvChaine & Right(LaCol__AP4(RienL), Len(LaCol__AP4(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5E Case 7 'cas 000 rang = 1 NouvChaine = "*/**/*/*" For RienL = 22 To UBound(LaCol__AP4) LaCol__AP4(RienL) = Left(LaCol__AP4(RienL), rang - 1) & NouvChaine & Right(LaCol__AP4(RienL), Len(LaCol__AP4(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Traitement_B5E Case 0 Traitement_B5E End Select Next TraitementD Exit Sub Erreur1d: RienL = RienL Stop: Resume End Sub Sub Traitement_B5E() On Error GoTo Erreur12 For TraitementE = 0 To 7 '7 RienL = RienL ReDim LaCol__AP(1 To NbLignes) For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = LaCol__AP5Sve(RienL) Next RienL Select Case TraitementE Case 1 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = Left(LaCol__AP5(RienL), rang - 1) & NouvChaine & Right(LaCol__AP5(RienL), Len(LaCol__AP5(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Case 2 rang = 3 NouvChaine = "**" For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = Left(LaCol__AP5(RienL), rang - 1) & NouvChaine & Right(LaCol__AP5(RienL), Len(LaCol__AP5(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Case 3 rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = Left(LaCol__AP5(RienL), rang - 1) & NouvChaine & Right(LaCol__AP5(RienL), Len(LaCol__AP5(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Case 4 rang = 1 NouvChaine = "*/**" For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = Left(LaCol__AP5(RienL), rang - 1) & NouvChaine & Right(LaCol__AP5(RienL), Len(LaCol__AP5(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Case 5 rang = 3 NouvChaine = "**/*" For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = Left(LaCol__AP5(RienL), rang - 1) & NouvChaine & Right(LaCol__AP5(RienL), Len(LaCol__AP5(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Case 6 rang = 1 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = Left(LaCol__AP5(RienL), rang - 1) & NouvChaine & Right(LaCol__AP5(RienL), Len(LaCol__AP5(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL rang = 6 NouvChaine = "*" For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = Left(LaCol__AP5(RienL), rang - 1) & NouvChaine & Right(LaCol__AP5(RienL), Len(LaCol__AP5(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Case 7 rang = 1 NouvChaine = "*/**/*/*" For RienL = 22 To UBound(LaCol__AP5) LaCol__AP5(RienL) = Left(LaCol__AP5(RienL), rang - 1) & NouvChaine & Right(LaCol__AP5(RienL), Len(LaCol__AP5(RienL)) - rang - (Len(NouvChaine) - 1)) Next RienL Case Else End Select 'voila on a les portions LaCol__APx que l'"on recolle pour faire LaCol__AP Qui sera affichée (LaCol__AP a auparavent été Redim dans cette Sub qui est la derniere du Traitement des bouts For RienL = 22 To UBound(LaCol__AP5) '=NbLignes LaCol__AP(RienL) = LaCol__AP1(RienL) + "-" + LaCol__AP2(RienL) + "-" + LaCol__AP3(RienL) + "-" + LaCol__AP4(RienL) + "-" + LaCol__AP5(RienL) 'LaCol__AP(RienL) est de la forme : "V/PB/G/M:2,0:0,50-R/PB/P/M:2,0:0,50-V/PB/P/M:2,0:0,50-R/DD/G/M:2,0:0,50-V/CH/G/M:2,0:0,50" ' la longueur de la chaine est CONSTANTE 'avec des variations qui sont des caractères V, P G M differents et des 2,0 ou 0,50 qui changent 'autre variation : les lettres sont remplacées par des "*" Write #intFic10, LaCol__AP(RienL) Write #intFic2, NbLignes Next RienL Next TraitementE Exit Sub Erreur12: RienL = RienL Stop: Resume End Sub
Option Explicit Option Base 1 Const col_A = 1: Const col_B = 2: Const Col_C = 3: Const Col_D = 4: Const Col_E = 5: Const Col_F = 6 Const col_G = 7: Const Col_H = 8: Const Col_I = 9: Const Col_J = 10: Const Col_K = 11: Const Col_L = 12 Const Col_M = 13: Const col_N = 14: Const Col_O = 15: Const Col_P = 16: Const Col_Q = 17: Const Col_R = 18 Const Col_S = 19: Const col_T = 20: Const Col_U = 21: Const Col_V = 22: Const Col_W = 23: Const Col_X = 24: Const Col_Y = 25 Const col_Z = 26 Const Col_AA = 26 + 1: Const Col_AB = 26 + 2: Const Col_AC = 26 + 3: Const Col_AD = 26 + 4: Const Col_AE = 26 + 5: Const Col_AF = 26 + 6 Const Col_AG = 26 + 7: Const Col_AH = 26 + 8: Const Col_AI = 26 + 9: Const Col_AJ = 26 + 10: Const Col_AK = 26 + 11: Const Col_AL = 26 + 12 Const Col_AM = 26 + 13: Const Col_AN = 26 + 14: Const Col_AO = 26 + 15: Const Col_AP = 26 + 16: Const Col_AQ = 26 + 17: Const Col_AR = 26 + 18 Const Col_AS = 26 + 19: Const Col_AT = 26 + 20: Const Col_AU = 26 + 21: Const Col_AV = 26 + 22: Const Col_AW = 26 + 23: Const Col_AX = 26 + 24 Const Col_AY = 26 + 25: Const col_AZ = 26 + 26 Dim NbEnregistrementsLusàlafois As Long Dim S_NbEnregistrementsLusàlafois As String Dim Repertoire As String Dim NomFichier1 As String Dim NomFichier10 As String Dim NomFichier2 As String Dim intFic2 Dim intFic10 Dim TraitementA As Byte Dim TraitementB As Byte Dim TraitementC As Byte Dim TraitementD As Byte Dim TraitementE As Byte Dim LaCol__AP() As String Dim RienC As Integer Dim RienL As Long Dim RienLResult As Long Dim NbLignes As Long Dim Cejour Dim CeMois Dim CetteAnnée Dim CetteDate As Date ' futur Const NbCasPossible = 32768 * 20 Const PremiereDonnéeFuturSignificative = 22 Dim FinLigneEltsFutur As Integer Dim LigneDateFutur As Integer Dim LesCasPourDateFutur(NbCasPossible) As String Dim RienCas As Long Dim MaxRienCas As Long Dim CasBase1 As String Dim CasBase2 As String Dim CasBase3 As String Dim CasBase4 As String Dim CasBase5 As String Dim ExCasBase1 As String Dim ExCasBase2 As String Dim ExCasBase3 As String Dim ExCasBase4 As String Dim ExCasBase5 As String Dim rang As Byte Dim NouvChaine As String Sub ChoisirFichier() Dim fd As FileDialog Dim vrtSelectedItem As Variant Dim FichierChoisiNomComplet As String Dim fs, f Dim SelectedItem Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Filters.Clear .Filters.Add "All files", "*.*" .InitialFileName = "C:\Users\Claude\Documents\" If .Show = -1 Then For Each SelectedItem In .SelectedItems FichierChoisiNomComplet = .SelectedItems.Item(1) Next SelectedItem Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFile(FichierChoisiNomComplet) NomFichier1 = f.Name For Each vrtSelectedItem In .SelectedItems Repertoire = Left(vrtSelectedItem, InStrRev(vrtSelectedItem, "\") - 1) Next vrtSelectedItem Else End If End With Set fd = Nothing End Sub Sub OuvreLesFichiersPourLire() On Error Resume Next ChoisirFichier NomFichier10 = "Les AP" + Left(Right(NomFichier1, Len(NomFichier1) - 4), Len(Right(NomFichier1, Len(NomFichier1) - 4)) - 4) NomFichier2 = "NbLigneDeChaquePage " + Left(Right(NomFichier1, Len(NomFichier1) - 4), Len(Right(NomFichier1, Len(NomFichier1) - 4)) - 4) ChDir Repertoire Close intFic2 = FreeFile Open NomFichier2 For Input As intFic2 intFic10 = FreeFile Open NomFichier10 For Input As intFic10 End Sub Sub FermeLesFichiers() Close End Sub Sub Initialisation() For RienL = 8 To 999999 If Worksheets("Les X - Y").Cells(RienL, Col_J) = Empty Then NbLignes = RienL - 1 Exit For End If Next RienL ReDim LaCol__AP(1 To NbLignes) End Sub Sub Cinq_B5_LireVirtuel() Initialisation OuvreLesFichiersPourLire ReDim LaCol__AP(1 To NbLignes) Lire1Enregistrement FermeLesFichiers MsgBox "Fini Lire" End Sub Sub Lire1Enregistrement() On Error GoTo Erreur99 Do While Not EOF(intFic2) Input #intFic2, S_NbEnregistrementsLusàlafois NbEnregistrementsLusàlafois = Val(S_NbEnregistrementsLusàlafois) ReDim LaCol__AP(NbEnregistrementsLusàlafois) For RienL = 1 To NbEnregistrementsLusàlafois Input #intFic10, LaCol__AP(RienL) For RienCas = 1 To MaxRienCas If LesCasPourDateFutur(RienCas) = LaCol__AP(RienL) Then CestTrouvé End If Next RienCas Next RienL Loop Exit Sub Erreur99: RienL = RienL Stop Resume End Sub Sub CestTrouvé() RienLResult = RienLResult + 1 Worksheets("Elts Results").Cells(RienLResult, Col_AS) = LaCol__AP(RienL) End Sub Sub DernierJour() For RienL = 8 To 999999 If Worksheets("Elts Futur").Cells(RienL, Col_J) = Empty Then FinLigneEltsFutur = RienL - 1 Exit For End If Next RienL End Sub Sub QuelleDate() Cejour = Worksheets("Les X - Y").Cells(23, col_B) CeMois = Worksheets("Les X - Y").Cells(24, col_B) CetteAnnée = Worksheets("Les X - Y").Cells(25, col_B) CetteDate = DateSerial(CetteAnnée, CeMois, Cejour) LigneDateFutur = 0 With Worksheets("Elts Futur") For RienL = PremiereDonnéeFuturSignificative + 1 To FinLigneEltsFutur If CetteDate = .Cells(RienL, Col_J) Then LigneDateFutur = RienL Exit For End If Next RienL End With End Sub Sub ListeDesCasParPage() With Worksheets("Elts Futur") CasBase1 = .Cells(LigneDateFutur, Col_AP).Value CasBase2 = .Cells(LigneDateFutur - 1, Col_AP).Value CasBase3 = .Cells(LigneDateFutur - 2, Col_AP).Value CasBase4 = .Cells(LigneDateFutur - 3, Col_AP).Value CasBase5 = .Cells(LigneDateFutur - 4, Col_AP).Value ExCasBase1 = CasBase1 ExCasBase2 = CasBase2 ExCasBase3 = CasBase3 ExCasBase4 = CasBase4 ExCasBase5 = CasBase5 'les CasBase1,CasBase2,CasBase3,CasBase4,CasBase5 sont de la meme structure : String 'ils ont la même longueur et se présentent comme ceci : "R/CB/M/M:4,0:0,20" 'avec des lettres qui peuvent changer, et des chiffres qui peuvent changer 'possibilité de "*" à la place des lettres par la sub Traitement_B5A End With Traitement_B5A End Sub Sub Traitement_B5A() For TraitementA = 0 To 7 CasBase1 = ExCasBase1 Select Case TraitementA Case 1 'cas 100 rang = 1 NouvChaine = "*" CasBase1 = Left(CasBase1, rang - 1) & NouvChaine & Right(CasBase1, Len(CasBase1) - rang - (Len(NouvChaine) - 1)) Traitement_B5B Case 2 ' cas 010 rang = 3 NouvChaine = "**" CasBase1 = Left(CasBase1, rang - 1) & NouvChaine & Right(CasBase1, Len(CasBase1) - rang - (Len(NouvChaine) - 1)) Traitement_B5B Case 3 'cas 001 rang = 6 NouvChaine = "*" CasBase1 = Left(CasBase1, rang - 1) & NouvChaine & Right(CasBase1, Len(CasBase1) - rang - (Len(NouvChaine) - 1)) Traitement_B5B Case 4 ' cas 110 rang = 1 NouvChaine = "*/**" CasBase1 = Left(CasBase1, rang - 1) & NouvChaine & Right(CasBase1, Len(CasBase1) - rang - (Len(NouvChaine) - 1)) Traitement_B5B Case 5 'cas 011 rang = 3 NouvChaine = "**/*" CasBase1 = Left(CasBase1, rang - 1) & NouvChaine & Right(CasBase1, Len(CasBase1) - rang - (Len(NouvChaine) - 1)) Traitement_B5B Case 6 'cas 101 rang = 1 NouvChaine = "*" CasBase1 = Left(CasBase1, rang - 1) & NouvChaine & Right(CasBase1, Len(CasBase1) - rang - (Len(NouvChaine) - 1)) rang = 6 NouvChaine = "*" CasBase1 = Left(CasBase1, rang - 1) & NouvChaine & Right(CasBase1, Len(CasBase1) - rang - (Len(NouvChaine) - 1)) Traitement_B5B Case 7 'cas 000 rang = 1 NouvChaine = "*/**/*/*" CasBase1 = Left(CasBase1, rang - 1) & NouvChaine & Right(CasBase1, Len(CasBase1) - rang - (Len(NouvChaine) - 1)) Traitement_B5B Case 0 Traitement_B5B End Select Next TraitementA End Sub Sub Traitement_B5B() For TraitementB = 0 To 7 CasBase2 = ExCasBase2 Select Case TraitementB Case 1 'cas 100 rang = 1 NouvChaine = "*" CasBase2 = Left(CasBase2, rang - 1) & NouvChaine & Right(CasBase2, Len(CasBase2) - rang - (Len(NouvChaine) - 1)) Traitement_B5C Case 2 ' cas 010 rang = 3 NouvChaine = "**" CasBase2 = Left(CasBase2, rang - 1) & NouvChaine & Right(CasBase2, Len(CasBase2) - rang - (Len(NouvChaine) - 1)) Traitement_B5C Case 3 'cas 001 rang = 6 NouvChaine = "*" CasBase2 = Left(CasBase2, rang - 1) & NouvChaine & Right(CasBase2, Len(CasBase2) - rang - (Len(NouvChaine) - 1)) Traitement_B5C Case 4 ' cas 110 rang = 1 NouvChaine = "*/**" CasBase2 = Left(CasBase2, rang - 1) & NouvChaine & Right(CasBase2, Len(CasBase2) - rang - (Len(NouvChaine) - 1)) Traitement_B5C Case 5 'cas 011 rang = 3 NouvChaine = "**/*" CasBase2 = Left(CasBase2, rang - 1) & NouvChaine & Right(CasBase2, Len(CasBase2) - rang - (Len(NouvChaine) - 1)) Traitement_B5C Case 6 'cas 101 rang = 1 NouvChaine = "*" CasBase2 = Left(CasBase2, rang - 1) & NouvChaine & Right(CasBase2, Len(CasBase2) - rang - (Len(NouvChaine) - 1)) rang = 6 NouvChaine = "*" CasBase2 = Left(CasBase2, rang - 1) & NouvChaine & Right(CasBase2, Len(CasBase2) - rang - (Len(NouvChaine) - 1)) Traitement_B5C Case 7 'cas 000 rang = 1 NouvChaine = "*/**/*/*" CasBase2 = Left(CasBase2, rang - 1) & NouvChaine & Right(CasBase2, Len(CasBase2) - rang - (Len(NouvChaine) - 1)) Traitement_B5C Case 0 Traitement_B5C End Select Next TraitementB End Sub Sub Traitement_B5C() For TraitementC = 0 To 7 CasBase3 = ExCasBase3 Select Case TraitementC Case 1 'cas 100 rang = 1 NouvChaine = "*" CasBase3 = Left(CasBase3, rang - 1) & NouvChaine & Right(CasBase3, Len(CasBase3) - rang - (Len(NouvChaine) - 1)) Traitement_B5D Case 2 ' cas 010 rang = 3 NouvChaine = "**" CasBase3 = Left(CasBase3, rang - 1) & NouvChaine & Right(CasBase3, Len(CasBase3) - rang - (Len(NouvChaine) - 1)) Traitement_B5D Case 3 'cas 001 rang = 6 NouvChaine = "*" CasBase3 = Left(CasBase3, rang - 1) & NouvChaine & Right(CasBase3, Len(CasBase3) - rang - (Len(NouvChaine) - 1)) Traitement_B5D Case 4 ' cas 110 rang = 1 NouvChaine = "*/**" CasBase3 = Left(CasBase3, rang - 1) & NouvChaine & Right(CasBase3, Len(CasBase3) - rang - (Len(NouvChaine) - 1)) Traitement_B5D Case 5 'cas 011 rang = 3 NouvChaine = "**/*" CasBase3 = Left(CasBase3, rang - 1) & NouvChaine & Right(CasBase3, Len(CasBase3) - rang - (Len(NouvChaine) - 1)) Traitement_B5D Case 6 'cas 101 rang = 1 NouvChaine = "*" CasBase3 = Left(CasBase3, rang - 1) & NouvChaine & Right(CasBase3, Len(CasBase3) - rang - (Len(NouvChaine) - 1)) rang = 6 NouvChaine = "*" CasBase3 = Left(CasBase3, rang - 1) & NouvChaine & Right(CasBase3, Len(CasBase3) - rang - (Len(NouvChaine) - 1)) Traitement_B5D Case 7 'cas 000 rang = 1 NouvChaine = "*/**/*/*" CasBase3 = Left(CasBase3, rang - 1) & NouvChaine & Right(CasBase3, Len(CasBase3) - rang - (Len(NouvChaine) - 1)) Traitement_B5D Case 0 Traitement_B5D End Select Next TraitementC End Sub Sub Traitement_B5D() For TraitementD = 0 To 7 CasBase4 = ExCasBase4 Select Case TraitementD Case 1 'cas 100 rang = 1 NouvChaine = "*" CasBase4 = Left(CasBase4, rang - 1) & NouvChaine & Right(CasBase4, Len(CasBase4) - rang - (Len(NouvChaine) - 1)) Traitement_B5E Case 2 ' cas 010 rang = 3 NouvChaine = "**" CasBase4 = Left(CasBase4, rang - 1) & NouvChaine & Right(CasBase4, Len(CasBase4) - rang - (Len(NouvChaine) - 1)) Traitement_B5E Case 3 'cas 001 rang = 6 NouvChaine = "*" CasBase4 = Left(CasBase4, rang - 1) & NouvChaine & Right(CasBase4, Len(CasBase4) - rang - (Len(NouvChaine) - 1)) Traitement_B5E Case 4 ' cas 110 rang = 1 NouvChaine = "*/**" CasBase4 = Left(CasBase4, rang - 1) & NouvChaine & Right(CasBase4, Len(CasBase4) - rang - (Len(NouvChaine) - 1)) Traitement_B5E Case 5 'cas 011 rang = 3 NouvChaine = "**/*" CasBase4 = Left(CasBase4, rang - 1) & NouvChaine & Right(CasBase4, Len(CasBase4) - rang - (Len(NouvChaine) - 1)) Traitement_B5E Case 6 'cas 101 rang = 1 NouvChaine = "*" CasBase4 = Left(CasBase4, rang - 1) & NouvChaine & Right(CasBase4, Len(CasBase4) - rang - (Len(NouvChaine) - 1)) rang = 6 NouvChaine = "*" CasBase4 = Left(CasBase4, rang - 1) & NouvChaine & Right(CasBase4, Len(CasBase4) - rang - (Len(NouvChaine) - 1)) Traitement_B5E Case 7 'cas 000 rang = 1 NouvChaine = "*/**/*/*" CasBase4 = Left(CasBase4, rang - 1) & NouvChaine & Right(CasBase4, Len(CasBase4) - rang - (Len(NouvChaine) - 1)) Traitement_B5E Case 0 Traitement_B5E End Select Next TraitementD End Sub Sub Traitement_B5E() On Error GoTo Erreur12 For TraitementE = 0 To 7 CasBase5 = ExCasBase5 Select Case TraitementE Case 1 rang = 1 NouvChaine = "*" CasBase5 = Left(CasBase5, rang - 1) & NouvChaine & Right(CasBase5, Len(CasBase5) - rang - (Len(NouvChaine) - 1)) Case 2 rang = 3 NouvChaine = "**" CasBase5 = Left(CasBase5, rang - 1) & NouvChaine & Right(CasBase5, Len(CasBase5) - rang - (Len(NouvChaine) - 1)) Case 3 rang = 6 NouvChaine = "*" CasBase5 = Left(CasBase5, rang - 1) & NouvChaine & Right(CasBase5, Len(CasBase5) - rang - (Len(NouvChaine) - 1)) Case 4 rang = 1 NouvChaine = "*/**" CasBase5 = Left(CasBase5, rang - 1) & NouvChaine & Right(CasBase5, Len(CasBase5) - rang - (Len(NouvChaine) - 1)) Case 5 rang = 3 NouvChaine = "**/*" CasBase5 = Left(CasBase5, rang - 1) & NouvChaine & Right(CasBase5, Len(CasBase5) - rang - (Len(NouvChaine) - 1)) Case 6 rang = 1 NouvChaine = "*" CasBase5 = Left(CasBase5, rang - 1) & NouvChaine & Right(CasBase5, Len(CasBase5) - rang - (Len(NouvChaine) - 1)) rang = 6 NouvChaine = "*" CasBase5 = Left(CasBase5, rang - 1) & NouvChaine & Right(CasBase5, Len(CasBase5) - rang - (Len(NouvChaine) - 1)) Case 7 rang = 1 NouvChaine = "*/**/*/*" CasBase5 = Left(CasBase5, rang - 1) & NouvChaine & Right(CasBase5, Len(CasBase5) - rang - (Len(NouvChaine) - 1)) Case Else End Select 'voila on a les portions LaCol__APx que l'"on recolle pour faire LaCol__AP Qui sera affichée (LaCol__AP a auparavent été Redim dans cette Sub qui est la derniere du Traitement des bouts RienCas = RienCas + 1 LesCasPourDateFutur(RienCas) = CasBase1 + "-" + CasBase2 + "-" + CasBase3 + "-" + CasBase4 + "-" + CasBase5 'ICI est la construction des LesCasPourDateFutur(RienCas) MaxRienCas = RienCas Next TraitementE Exit Sub Erreur12: RienL = RienL Stop: Resume End Sub Sub Rechercher() DernierJour QuelleDate If LigneDateFutur = 0 Then MsgBox "Pas Une Date Significative" Exit Sub End If RienLResult = 8 ListeDesCasParPage 'là on a le tableau de chaines LesCasPourDateFutur(RienCas) avec RienCas de 1 à MaxRienCas Cinq_B5_LireVirtuel End Sub
Str(Day(Date)) + "-" + Str(Month(Date)) + "-" + Str(Year(Date)) + "-" + Str(Hour(Time)) + "H -" + Str(Minute(Time)) + "Mn"
Format(Now, "dd-mm-yyyy-hh\H-mm\M\n")
11 févr. 2015 à 10:17
Donc la version est primordiale pour te répondre.