jbballeyguier
XLDnaute Nouveau
Bonjour,
j'ai un petit soucis avec une macro.
L'idée est de faire une recherche de fichiers, d'ouvrir un par un les fichiers et de traiter les données dans ces fichiers. J'utilise la fonction filesearch, et je place le nom de chaque fichier dans un variant.
Le problème c'est que je voudrais récupérer le nom du fichier et le placer dans une variable string (j'ai l'impression que c'est plus simple à traiter.) Cependant, lorsque j'exécute la macro, il bute justement sur le passage de cette variant en string :
Erreur : "l'indice n'appartient pas à la sélection"
Voilà la totalité du code :
Auriez-vous une idée pour résoudre ce problème ?
j'ai un petit soucis avec une macro.
L'idée est de faire une recherche de fichiers, d'ouvrir un par un les fichiers et de traiter les données dans ces fichiers. J'utilise la fonction filesearch, et je place le nom de chaque fichier dans un variant.
Le problème c'est que je voudrais récupérer le nom du fichier et le placer dans une variable string (j'ai l'impression que c'est plus simple à traiter.) Cependant, lorsque j'exécute la macro, il bute justement sur le passage de cette variant en string :
Code:
Ench = Cstr(NomFic)Voilà la totalité du code :
Code:
Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Function ClipBoard_Clear()
Call OpenClipboard(0&)
Call EmptyClipboard
Call CloseClipboard
End Function
Sub ploum()
Call macro1
Call Module2.InputPourRax
End Sub
Sub MaJ_PlandeTests()
Dim ScanFic As Office.FileSearch
Dim NomFic As Variant
Dim racine As String
Dim chemin As String
Dim Ench As String
Dim NomEnch As String
Dim ligne As Integer
ThisWorkbook.Worksheets("INPUT").Range("A2:Q12000").ClearContents
ThisWorkbook.Worksheets("Suivi global").Range("C2:C500").ClearContents
Application.CutCopyMode = False
Set ScanFic = Application.FileSearch
ligne = 2
h = 1
Do While ThisWorkbook.Sheets("Nomenclature").Cells(h, 1) <> ""
ThisWorkbook.Activate
Sheets("Nomenclature").Activate
Cells(h, 1).Select
racine = ThisWorkbook.Sheets("Nomenclature").Cells(h, 1)
chemin = (ThisWorkbook.Path & "\" & racine)
' On recherche les fichiers dans l'arborescence et on les ouvre
With ScanFic
.NewSearch
.LookIn = chemin
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
.Execute
' On ouvre les fichiers trouvés et on les traite un par un
For Each NomFic In .FoundFiles
Workbooks.Open Filename:=NomFic, UpdateLinks:=False
Ench = CStr(NomFic)
'MsgBox Ench
Workbooks(Ench).Activate
ActiveWorkbook.Sheets("CR détaillé").Activate
NomEnch = Range("C1").Value
'NomEnch = Workbooks(Ench).Sheets("CR détaillé").Range("C1").Value
' Effectue la copie des colonnes A à N
Dim j As Integer
j = 1
blanc = 0
Sheets("CR détaillé").Activate
Do While blanc < 2
If Worksheets("CR détaillé").Cells(j, 1) = "" Then blanc = blanc + 1
If Worksheets("CR détaillé").Cells(j, 1) <> "" Then blanc = 0
j = j + 1
Loop
MsgBox j
Dim fin As Integer
fin = 1
fin = j - 2
Cells(fin, 8).Value = "FIN"
' On supprime les lignes inutiles
Worksheets("CR Détaillé").Activate
Range(Cells(3, 15), Cells(fin, 15)).Value = NomEnch 'Met le numéro de l'enchainement dans la colonne O
j = 2
Do While Cells(j, 8).Value <> "FIN"
Cells(j, 8).Select
' On se sert de la mise en forme des lignes que l'on veut supprimer, c'est bourrin mais ça marche
If Cells(j, 2).Interior.ColorIndex = 56 And Cells(j + 1, 1) = "" Then
Range(Cells(j, 1), Cells(j + 1, 15)).Select
Selection.Delete xlUp
ElseIf Cells(j, 1) = "" Or Cells(j, 2).Interior.ColorIndex = 16 Or Cells(j, 2).Interior.ColorIndex = 56 Then
Range(Cells(j, 1), Cells(j, 15)).Select
Selection.Delete xlUp
End If
'MsgBox True
j = j + 1
Loop
fin = j - 1
'On copie les lignes qui nous intéressent
Range(Cells(4, 1), Cells(fin, 15)).Select
Selection.Copy
ThisWorkbook.Activate
Worksheets("INPUT").Activate
Range(Cells(ligne, 1), Cells(fin, 14)).Select
ActiveSheet.Paste
' On ferme la fiche d'enchainement pour passer à la suivante
ClipBoard_Clear
Workbooks(Ench).Close savechanges:=False
ligne = fin - 1 'Pour éviter d'écraser les lignes collées par les suivantes
Next
End With
h = h + 1
Loop
'On supprime les mises en forme et les colonnes inutiles
ThisWorkbook.Sheets("INPUT").Cells.Select
Selection.ClearFormats
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Range("U1").Activate
Range("C:C,F:G,K:N").Select
Selection.Delete shift:=xlToLeft
' Renommage des colonnes
Range("A1").Value = "Pas"
Range("B1").Value = "Action"
Range("C1").Value = "Domaine"
Range("D1").Value = "M.A"
Range("E1").Value = "Fiche"
Range("F1").Value = "Titre"
Range("G1").Value = "N° de cas"
Range("H1").Value = "Enchainement"
With Range("A1:F1")
.Interior.ColorIndex = 1
.Font.ColorIndex = 2
.Font.Bold = True
End With
Cells.Select
Cells.EntireColumn.AutoFit
End SubAuriez-vous une idée pour résoudre ce problème ?
