type d'argument byref incompatible

Bonjour à tous,

J'ai une macro qui me permet de découper un fichier en plusieurs fichiers suivant certains critères. Le split fonctionnait correctement j'avais moins de 32000 lignes dans mon fichier, aujourd'hui, je suis proche de 40000 lignes.

J'ai donc eu un dépassement de capacité, j'ai passé quelques variable en long. Le processus a donc passé ces étapes jusqu'au message "type d'argument byref incompatible". et là, je sèche complètement, je ne suis pas à l'origine de cette macro, je m'y perd un peu.

Voici le code global.

L'exécution de la macro commence par SplitToutesFeuilles

Code:

---

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 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622

Dim tab_infos(50) As Variant Sub InitExport() Dim i As Long   For i = 0 To UBound(tab_infos) tab_infos(i) = "" Next i End Sub Function DejaInfos(name As String) As Boolean Dim i As Long   trouve = False i = 0 While Not trouve And i <= UBound(tab_infos) If tab_infos(i) = name Then trouve = True Else i = i + 1 End If Wend DejaInfos = trouve End Function Sub InsertTabInfos(name As String) Dim i As Long   trouve = False i = 0 While Not trouve And i <= UBound(tab_infos) If tab_infos(i) = "" Then tab_infos(i) = name trouve = True Else If tab_infos(i) = name Then trouve = True Else i = i + 1 End If End If Wend   End Sub Sub TraitementSplit(source As String, champ As String, champ2 As String, critere As String, rgp As Boolean) ' Traitement de l'onglet source qui est splité selon le champ, le champ2 servant de critere de regroupement si rgp est vrai ' La valeur de critere peut servir à ne sélectionner que les enregistrement répondant à sa valeur Dim val_champ1 As String Dim val_champ2 As String Dim i As Long Dim soc As Integer Dim bu As Integer Dim col As Integer   Application.ScreenUpdating = False Application.Calculation = xlManual ' bloque le calcul automatique. soc = LabelLigne(source, champ, 1) If soc < 0 Then MsgBox ("ATTENTION le libellé du champ utilisé pour le split n'existe pas dans le fichier source : " & champ) Exit Sub End If If champ2 <> "" Then bu = LabelLigne(source, champ2, 1) End If If critere = "" Then col = -1 Else col = soc End If i = 2 nb_enreg = Application.Min(Range("NB_enregistrements"), LastFreeLine(source) - 1)   While Worksheets(source).Cells(i, 1) <> "" And i - 1 <= nb_enreg 'Application.StatusBar = i & " / " & nb_enreg If IsError(Worksheets(source).Cells(i, soc)) Then GoTo Skip End If val_champ1 = Worksheets(source).Cells(i, soc) If rgp Then If champ2 <> "" And bu > 0 Then If IsError(Worksheets(source).Cells(i, bu)) Then GoTo Skip End If val_champ2 = Worksheets(source).Cells(i, bu) End If val_champ1 = Regroupement2(val_champ1, val_champ2) End If If TestCritere(val_champ1, col, critere) Then Call TestOnglet(val_champ1) If LastFreeLine(val_champ1) - 1 = 1 Then Call LigneEntete(source, val_champ1) End If Worksheets(source).Activate Rows(i & ":" & i).Select Selection.Copy Worksheets(val_champ1).Select lg = LastFreeLine(val_champ1) Worksheets(val_champ1).Activate Rows(lg & ":" & lg).Select ActiveSheet.Paste End If Skip: i = i + 1 Wend Application.Calculation = xlAutomatic ' remet en place le calcul automatique End Sub Sub InitFields() Worksheets("Actions").Activate Range("FichierATraiter").Select Call FormatCell("Normal") Range("OngletATraiter").Select Call FormatCell("Normal") Range("ListeVal").Select Call FormatCell("Normal") Range("CritereSelect").Select Call FormatCell("Normal") End Sub Sub SplitToutesFeuilles() Dim nomfichier As String Dim feuille As String Dim lst() Dim i As Long lst = Range("Liste_Onglets").Value nomfichier = "" Call DebutChrono(True) Call InitExport   For i = 1 To UBound(lst) feuille = lst(i, 1) If Len(feuille) > 0 Then Application.StatusBar = "Import de " & feuille Application.DisplayAlerts = False nomfichier = SelectLoadFeuille(feuille, nomfichier) Application.DisplayAlerts = True Range("FichierATraiter").Value = nomfichier Range("OngletATraiter").Value = feuille FormatFeuille (feuille) Range("OngletAtraiter").Value = feuille Application.StatusBar = "Traitement de " & feuille Call SplitparSociete Application.StatusBar = "Export de " & feuille Call ExportFichiers Application.DisplayAlerts = False Worksheets(feuille).Delete Application.DisplayAlerts = True End If Next i Application.StatusBar = "FIN : " & ArretChrono(True) / 60 End Sub Sub SplitToutesFeuilles2() Dim nomfichier As String Dim feuille As String Dim lst() Dim i As Long lst = Range("Liste_Onglets").Value nomfichier = "" Call DebutChrono(True) Call InitExport   For i = 1 To UBound(lst) feuille = lst(i, 1) If Len(feuille) > 0 Then Application.StatusBar = "Import de " & feuille Application.DisplayAlerts = False nomfichier = SelectLoadFeuille(feuille, nomfichier) Application.DisplayAlerts = True Range("FichierATraiter").Value = nomfichier Range("OngletATraiter").Value = feuille FormatFeuille (feuille) Range("OngletAtraiter").Value = feuille Application.StatusBar = "Traitement de " & feuille Call SplitparSociete Application.DisplayAlerts = False Worksheets(feuille).Delete Application.DisplayAlerts = True End If Next i   Application.StatusBar = "Export" Call ExportFichiers   Application.StatusBar = "FIN : " & ArretChrono(True) / 60 End Sub Function CTRL_RGP(onglet As String, champ1 As String, champ2 As String, Optional champ3 As String) As Boolean Dim i As Long   c1 = LabelLigne(onglet, champ1, 1) If champ2 <> "" Then c2 = LabelLigne(onglet, champ2, 1) Else c2 = 1 End If If champ3 <> "" Then c3 = LabelLigne(onglet, champ3, 1) Else c3 = 1 End If   If c1 > 0 And c2 > 0 And c3 > 0 Then CTRL_RGP = True Else CTRL_RGP = False End If   End Function Sub SplitparSociete() Dim onglet As String Dim champ As String Dim champ2 As String Dim champ3 As String Dim critere As String Dim tri As String Dim rgp As Boolean Dim perf As Boolean Dim ctrl As Boolean   Call Param_Off   Call DebutChrono Call InitFields Call RAZ_Rapport("Error") Worksheets("Actions").Activate onglet = Range("OngletAtraiter").Value champ = Range("ListeVal").Value critere = Range("CritereSelect").Value perf = Range("Perf").Value   If Range("Regroupement").Value = "Oui 2 critères" Then rgp = True champ2 = Range("RGP").Cells(1, 2) ctrl = CTRL_RGP(onglet, champ, champ2) Else If Range("Regroupement").Value = "Oui 3 critères" Then rgp = True champ2 = Range("RGP").Cells(1, 2) ctrl = CTRL_RGP(onglet, champ, champ2) champ3 = Range("RGP").Cells(1, 3) ctrl = ctrl And CTRL_RGP(onglet, champ, champ3) Else ctrl = True rgp = False End If End If   If Not ctrl Then MsgBox "Les champs de regroupements n'existent pas dans l'onglet à traiter. Veuillez corriger le paramétrage" Else If Range("FichierAtraiter").Value = "" Then Range("FichierAtraiter").Select Call FormatCell("Insatisfaisant") MsgBox "Veuillez choisir un fichier à traiter" Else If onglet = "" Or Range("FichierAtraiter").Value = "" Then Range("OngletAtraiter").Select Call FormatCell("Insatisfaisant") MsgBox "Veuillez choisir un fichier à traiter" Else If champ = "" Then Range("ListeVal").Select Call FormatCell("Insatisfaisant") MsgBox "Veuillez saisir le champ sur lequel le traitement basera le split" Else x = LabelLigne(onglet, Range("CritereTri").Value, 1) tri = ConvertToLetter(LabelLigne(onglet, Range("CritereTri").Value, 1)) oldStatusBar = Application.DisplayStatusBar If perf Then Call TraitementSplitPerf(onglet, champ, champ2, critere, rgp, champ3) Else Call TraitementSplit(onglet, champ, champ2, critere, rgp) End If Call FormatToutesFeuilles(tri, onglet) Application.ScreenUpdating = True Worksheets("Actions").Activate 'If SheetExists("Error") And LastFreeLine("Error") - 1 > 1 Then ' MsgBox "Fin de traitement avec ERREUR : " & ArretChrono & " secondes" 'Application.StatusBar = "Fin de traitement avec ERREUR : " & ArretChrono & " secondes" 'Else ' MsgBox "Fin de traitement : " & ArretChrono & " secondes" 'Application.StatusBar = "Fin de traitement : " & ArretChrono & " secondes" 'End If Range("EXEC_Time") = ArretChrono / 60 ' Application.StatusBar = oldStatusBar End If End If End If End If Call Param_On   End Sub Sub FormatToutesFeuilles(tri As String, Optional onglet_src As String) Dim i As Long Application.ScreenUpdating = False i = 1 While Worksheets(i).name <> "Actions" If Worksheets(i).name <> "Error" Then If onglet_src <> "" Then Call FormatFeuilleRef(Worksheets(i).name, onglet_src) Else Call FormatFeuille(Worksheets(i).name) End If If tri <> "" Then Call FormatTri(Worksheets(i).name, tri) End If End If i = i + 1 Wend Application.ScreenUpdating = True End Sub Sub FormatTri(onglet As String, tri As String) Worksheets(onglet).Activate rg = tri & "1:" & tri & LastFreeLine(onglet) - 1 Call SetFilter(onglet) Worksheets(onglet).AutoFilter.Sort.SortFields.Add2 Key:=Range(rg), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers With Worksheets(onglet).AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With   End Sub   Sub LigneEntete(src As String, targ As String) Worksheets(src).Activate Rows(1 & ":" & 1).Select Selection.Copy Worksheets(targ).Select Worksheets(targ).Activate Rows(1 & ":" & 1).Select ActiveSheet.Paste End Sub Function Regroupement(critere As String) As String Dim res As String Dim i As Long rgp = "Regroupements" If critere = "" Then trouve = True Else trouve = False End If i = 1 res = critere While Worksheets(rgp).Cells(i, 1) <> "" And Not trouve If Worksheets(rgp).Cells(i, 1) = critere Then trouve = True res = Worksheets(rgp).Cells(i, 2) End If i = i + 1 Wend Regroupement = res End Function Function Regroupement2(critere As String, critere2 As String) As String Dim res As String Dim As Long rgp = "Regroupements" If critere = "" Then trouve = True Else trouve = False End If i = 2 res = critere While Worksheets(rgp).Cells(i, 1) <> "" And Not trouve xx = Worksheets(rgp).Cells(i, 1) If Worksheets(rgp).Cells(i, 1) = critere Then If Worksheets(rgp).Cells(i, 2) = "*" Or Worksheets(rgp).Cells(i, 2) = critere2 Then trouve = True res = Worksheets(rgp).Cells(i, 3) End If End If i = i + 1 Wend If Not trouve Then Call TestOnglet("Error") i = LastFreeLine("Error") Worksheets("Error").Cells(i, 1) = critere Worksheets("Error").Cells(i, 2) = critere2 Worksheets("Error").Cells(i, 3) = "Criteres de regroupement introuvables" End If Regroupement2 = res End Function Sub ExportFichiers() Dim rep As String Dim fichier As String Dim nomfic As String Dim nom As String Dim ficexp As String Dim colfixe As String Dim cartouche As String Dim onglet As String Dim feuilleAtraiter As String Dim verrou1 As String Dim verrou2 As String Dim mdp As String Dim bverrou As Boolean Dim cf As String Dim i As Long   Application.ScreenUpdating = False racine = Range("DossierExport") onglet = Range("OngletATraiter") cf = Range("ColFixe") ' colfixe = ConvertToLetter(LabelLigne(onglet, Range("ColFixe"), 1) + 1) cartouche = Range("CSP_CARTOUCHE").Cells(1, 1) If cartouche <> "" Then Call TestOnglet("Infos") Sheets("Infos").Move after:=Sheets(Worksheets.Count) Worksheets("Actions").Activate Worksheets("Actions").Range("CSP_CARTOUCHE").Select Selection.Copy Worksheets("Infos").Activate Worksheets("Infos").Cells(1, 1).Select ' Coller valeur avec mise en forme Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If   extension = ".xlsx"   If Range("ExportUnSeulFichier") = "Oui" Then onefic = True 'Nom du fichier d'export ficexp = Range("FichierExport").Value Else onefic = False End If verrou = Range("Verrouillage") If verrou = "Oui" Then bverrou = True mdp = Range("MDP") verrou1 = "" verrou2 = "" If Range("ColDéverouillage") > 0 Then verrou1 = ConvertToLetter(Range("ColDéverouillage")) verrou2 = ConvertToLetter(Range("ColDéverouillage") + 5) End If Else bverrou = False End If   di = Range("DossierInter") If di = "Oui" Then bdi = True Else bdi = False End If     i = 1 nb = 0 While Worksheets(i).name <> "Actions" If Worksheets(i).name <> "Error" Then If bdi Then dossier = DossierIntermediaire(Worksheets(i).name) rep = racine & "\" & dossier Else rep = racine & "\" & Worksheets(i).name ' rep = racine End If res = CreerDossier(rep) nom = Worksheets(i).name If onefic = False Then ficexp = onglet End If nomfic = Trigramme(Worksheets(i).name, ficexp) fichier = rep & "\" & nomfic & extension   colfixe = ConvertToLetter(LabelLigne(nom, cf, 1) + 1)   Application.DisplayAlerts = False 'ajouter l'onglet If Not DejaInfos(nomfic) Then Call InsertTabInfos(nomfic) Call CopieFeuille(fichier, "Infos", "Infos", "", "", "", False, "") End If If onefic Then Call CopieFeuille(fichier, nom, onglet, colfixe, verrou1, verrou2, bverrou, mdp) Else Call CopieFeuille(fichier, nom, onglet, colfixe, verrou1, verrou2, bverrou, mdp) End If   ' suppression de la feuille copiée Worksheets(nom).Delete   Application.DisplayAlerts = True nb = nb + 1 Else i = i + 1 End If Wend Application.ScreenUpdating = True   'Application.StatusBar = "Nombre de fichiers créés = " & nb End Sub Function Trigramme(entite As String, onglet) As String ' La fonction Trigramme sert à générer le nom du fichier qui sera exporté en fonction de l'entité et de l'onglet ' le trigramme de l'entité est paramétré dans le champ nommé "CSP_TRIG" trig = Range("CSP_TRIG")   ' recherche du nom de l'entité i = 1 trouve = False While trig(i, 1) <> "" And Not trouve If trig(i, 1) = entite Then Trigramme = trig(i, 2) & "_" & onglet trouve = True End If i = i + 1 Wend If Not trouve Then Trigramme = onglet ' MsgBox "Le trigramme de l'entité " & entite & " n'a pas été indentifié" End If End Function Function DossierIntermediaire(nom As String) As String ' La fonction Trigramme sert à identifier le nom du dossier qui sera utilisé ' le nom est paramétré dans le champ nommé "CSP_DOSSIER" Dim i As Long   dosin = Range("CSP_DOSSIER")   ' recherche du nom i = 2 trouve = False While dosin(i, 1) <> "" And Not trouve If dosin(i, 1) = nom Then DossierIntermediaire = dosin(i, 2) trouve = True End If i = i + 1 Wend If Not trouve Then DossierIntermediaire = "" End If End Function   Sub RAZ_Feuilles() ' Fonction pour supprimer toutes les feuilles créées par le traitement et qui se situent à gauche de la feuille "Actions" Dim i As Long Application.ScreenUpdating = False i = 1 While Worksheets(1).name <> "Actions" Application.DisplayAlerts = False Worksheets(1).Delete Application.DisplayAlerts = True i = i + 1 Wend Application.ScreenUpdating = True Call InitExport   MsgBox "Nombre de feuilles supprimées = " & i - 1 End Sub Function CreerDossier(Chemin As String) As Boolean 'par: Excel-Malin.com ( https://excel-malin.com ) On Error GoTo CreerDossierErreur   Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject")   If Len(Dir(Chemin, vbDirectory)) > 0 Then CreerDossier = True Exit Function Else 'suppression du dernier backslash si présent If Right(Chemin, 1) = Application.PathSeparator Then Chemin = Left(Chemin, Len(Chemin) - 1)   'vérificacion si chemin local ou réseau If Left(Chemin, 2) = "\\" Then CheminReseau = True Else CheminReseau = False End If   'décomposition du chemin If CheminReseau = False Then PartiesDeChemin = Split(Chemin, Application.PathSeparator) CheminPartielOK = "" PremierDossier = LBound(PartiesDeChemin) Else PartiesDeChemin = Split(Replace(Chemin, "\\", ""), Application.PathSeparator) CheminPartielOK = "" PremierDossier = LBound(PartiesDeChemin) + 1 End If   'tests et créations de (sous)dossiers For PartieDeChemin = PremierDossier To UBound(PartiesDeChemin)   For CheminPartiel = LBound(PartiesDeChemin) To PartieDeChemin   If CheminReseau = False Then CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator Else CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator End If   If CheminPartiel = PartieDeChemin Then If CheminReseau = False Then If FSO.FolderExists(CheminPartielOK) = False Then MkDir CheminPartielOK End If Else If Right(CheminPartielOK, 1) = Application.PathSeparator Then _ CheminPartielOK = Left(CheminPartielOK, Len(CheminPartielOK) - 1)   If Left(CheminPartielOK, 2) <> "\\" Then _ CheminPartielOK = "\\" & CheminPartielOK   If FSO.FolderExists(CheminPartielOK) = False Then MkDir CheminPartielOK End If End If End If Next CheminPartiel CheminPartielOK = "" Next PartieDeChemin End If   CreerDossier = True Exit Function CreerDossierErreur: CreerDossier = False End Function

---

Code:

---

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 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194

Dim Data_RGP As Variant Dim nb_RGP As Long Dim DataRangeSRC As Variant Dim DataRangeTRG As Variant   Sub TraitementSplitPerf(source As String, champ As String, champ2 As String, critere As String, rgp As Boolean, Optional champ3 As String) ' Traitement de l'onglet source qui est splité selon le champ, le champ2 servant de critere de regroupement si rgp est vrai ' La valeur de critere peut servir à ne sélectionner que les enregistrement répondant à sa valeur Dim val_champ1 As String Dim val_champ2 As String Dim val_champ3 As String Dim oldval As String Dim i As Long Dim c1 As Integer Dim c2 As Integer Dim c3 As Integer Dim nb As Integer Dim col As Integer Dim debut As Long Dim fin As Long Dim dercol As Integer Dim colonne As String Dim nb_enreg As Long   Application.ScreenUpdating = False Application.Calculation = xlManual ' bloque le calcul automatique. c1 = LabelLigne(source, champ, 1) If c1 < 0 Then MsgBox ("ATTENTION le libellé du champ utilisé pour le split n'existe pas dans le fichier source : " & champ) Exit Sub End If   nb = 1 If champ2 <> "" Then c2 = LabelLigne(source, champ2, 1) rg2 = ConvertToLetter(c2) nb = 2 Else c2 = -1 End If If champ3 <> "" Then c3 = LabelLigne(source, champ3, 1) rg3 = ConvertToLetter(c3) nb = 3 Else c3 = -1 End If   If critere = "" Then col = -1 Else col = c1 End If   If rgp Then Call Load_RGP(nb) End If   i = 2 nb_enreg = Application.Min(Range("NB_enregistrements"), LastFreeLine(source) - 1) ' tri de la feuille selon le critère de split rg1 = ConvertToLetter(c1) Call SetFilter(source) ActiveWorkbook.Worksheets(source).AutoFilter.Sort.SortFields.Add2 Key:=Range(rg1 & "1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers If c2 > 0 Then ActiveWorkbook.Worksheets(source).AutoFilter.Sort.SortFields.Add2 Key:=Range(rg2 & "1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers End If If c3 > 0 Then ActiveWorkbook.Worksheets(source).AutoFilter.Sort.SortFields.Add2 Key:=Range(rg3 & "1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers End If   With ActiveWorkbook.Worksheets(source).AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With   dercol = Worksheets(source).Cells(1, Columns.Count).End(xlToLeft).Column colonne = ConvertToLetter(dercol) DataRangeSRC = Worksheets(source).Range("A2:" & colonne & nb_enreg + 1) i = 1 While i <= nb_enreg If DataRangeSRC(i, 1) <> "" Then 'DataRangeTRG = Worksheets(source).Range("A" & i & ":AG" & i) 'Application.StatusBar = i & " / " & nb_enreg If IsError(DataRangeSRC(i, c1)) Then GoTo Skip End If val_champ1 = DetermineFeuille(i, c1, rgp, c2, c3) If TestCritere(val_champ1, col, critere) Then debut = i + 1 Call TestOnglet(val_champ1) If LastFreeLine(val_champ1) - 1 = 1 Then Call LigneEntete(source, val_champ1) End If oldval = val_champ1 While val_champ1 = oldval i = i + 1 val_champ1 = DetermineFeuille(i, c1, rgp, c2, c3) Wend fin = i   nbl = fin - debut ReDim DataRangeTRG(nbl, dercol) DataRangeTRG = Worksheets(source).Range("A" & debut & ":" & colonne & fin) lg = LastFreeLine(oldval) x = lg + nbl Worksheets(oldval).Range("A" & lg & ":" & colonne & x) = DataRangeTRG i = i - 1 End If End If Skip: i = i + 1 Wend Application.Calculation = xlAutomatic ' remet en place le calcul automatique End Sub   Function DetermineFeuille(lg As Integer, idx1 As Integer, rgp As Boolean, idx2 As Integer, idx3 As Integer) As String Dim v1 As String Dim v2 As String Dim v3 As String   v1 = DataRangeSRC(lg, idx1) If rgp Then If idx2 > 0 Then v2 = DataRangeSRC(lg, idx2) End If If idx3 > 0 Then v3 = DataRangeSRC(lg, idx3) End If v1 = Regroupement3(v1, v2, v3) End If DetermineFeuille = v1 End Function Sub Load_RGP(nbchamp As Integer) Dim rgp As String Dim i As Long   rgp = "Regroupements" i = LastFreeLine(rgp) - 1 x = ConvertToLetter(nbchamp + 1) Data_RGP = Worksheets(rgp).Range("A2:" & x & i) nb_RGP = i End Sub Function Regroupement3(critere As String, critere2 As String, critere3 As String) As String Dim res As String Dim i As Long   rgp = "Regroupements" If critere = "" Then trouve = True Else trouve = False End If If critere3 = "" Then crit3 = False Else crit3 = True End If   i = 1 res = critere While Not trouve And i < nb_RGP If Data_RGP(i, 1) = critere Then If crit3 Then If (Data_RGP(i, 2) = "*" Or Data_RGP(i, 2) = critere2) And (Data_RGP(i, 3) = "*" Or Data_RGP(i, 3) = critere3) Then trouve = True res = Data_RGP(i, 4) End If Else If Data_RGP(i, 2) = "*" Or Data_RGP(i, 2) = critere2 Then trouve = True res = Data_RGP(i, 3) End If End If End If i = i + 1 Wend If Not trouve Then Call TestOnglet("Error") i = LastFreeLine("Error") Worksheets("Error").Cells(i, 1) = critere Worksheets("Error").Cells(i, 2) = critere2 If crit3 Then Worksheets("Error").Cells(i, 3) = critere3 Worksheets("Error").Cells(i, 4) = "Criteres de regroupement introuvables" Else Worksheets("Error").Cells(i, 3) = "Criteres de regroupement introuvables" End If End If Regroupement3 = res End Function

---

Désolé, ça fait beaucoup de codes. Si vous avez une idée de ce qui pourrait me donner ce message d'erreur, je suis preneur.

D'avance merci pour votre

Cdt,

Meumeu

Bonjour meumeu73.1

Il manque déjà une fonction ou une sub dans le code donné :scarymov:

Quand vous avez

Code:

---

c1 = LabelLigne(source, champ, 1)

---

Ou est LabelLigne ?

A+

Bonjour,

Aurais tu la possibilité de joindre un fichier ?

Citation:

---

Envoyé par BrunoM45

Bonjour meumeu73.1

Il manque déjà une fonction ou une sub dans le code donné :scarymov:

Quand vous avez

Code:

---

c1 = LabelLigne(source, champ, 1)

---

Ou est LabelLigne ?

A+

---

J'au du mal copié mon code pour le Sub.

J'ai déclaré LabelLigne en Long, j'ai un autre message d'erreur " Erreur de compilation - Tableau Attendu "

la ligne surligné en jaune

Code:

---

Sub TraitementSplitPerf(source As String, champ As String, champ2 As String, critere As String, rgp As Boolean, Optional champ3 As String)

---

Quel est ton niveau en VBA ?

Si tu es débutant, ce n'est même pas la peine d'espérer comprendre ce code, et encore moins le mettre à jour.
Il est juste horrible !
je n'énumèrerai pas toutes les bêtises qu'il y a dedans, la liste serait trop longue.

Le plus prudent est peut être de repartir du code originel (et non celui que tu à modifié).

Aurais tu la possibilité de joindre un fichier ?

Bonjour,

Je suis un peu plus que débutant, mais pas vraiment expert, c'est pour cela que je demande de l'aide.

Voici le code original (SpliPerformanceV5 - Test.xlsm)

Je rappelle le premier message d'erreur que j'ai eu problème : dépassement de capacité, d'après ce que j'avais lu, il fallait passer certaines variables de Integer à Long. Mon fichier est passé de 30000 lignes à 39000 lignes.

J'ai joint un fichier test (SOURCE TEST.xlsm).

Fonctionnement du Split :
2 méthodes

Split d'une feuille pour 1 fichier splitté en plusieurs fichiers : c'est la partie à gauche avec les étapes 1, 2 et 3.

Split des plusieurs feuilles en plusieurs fichiers : c'est le bouton qui est positionné en F29 : rapports_multionglets (exports séparés)

c'est ce dernier qui m’intéresse.

En cliquant sur ce bouton, il va me demander quel fichier je veux splitter (SOURCE TEST.xslm), j'ai déjà indiquer les onglets que je voulais splitter en colonne G (FICHIER 1, FICHIER 2,....), le champ a utilisé est SPLIT (indiqué en E7)

Le split doit s'effectuer et les fichiers seront positionnés dans le répertoire suivant le chemin indiqué en F14, il doit créé un dossier par SPLIT1, SPLIT2, ... et mettre le fichier SPLIT avec les onglets FICHIER 1, FICHIER 2,....

J'espère que mes explications sont à peu près clair.

Merci.

Bonjour,

Nous avons testé simplement en faisant un rechercher remplacer de integer > Long, ça m'a réglé le problème.

Certes le code n'est certainement pas parfait, mais pour le moment, il reste efficace.

Merci pour votre aide et implication.