New_Flo2002
XLDnaute Nouveau
Bonjour à tous,
Il y a bien longtemps que je ne suis pas venu sur ce forum, j'en ai d'ailleurs perdu tous mes acces !
Je vous avoue que c'est un sérieux problème (pour moi) qui me fais revenir vers vous (je suis assez interressé sur ce sujet mais j'esperes dépanner un ou deux débutant en échange
Mon problème a déjà abordé dans de nombreux sujets mais je n'arrive pas à appliquer les solutions porposées à mon code.
Pour faire simple, ce code est dans un fichier excel qui va lire dans des fichiers excel pour récupérer des informations.
Ci-dessous un extrait du fameux code qui fonctionnait sous 2003 avec la variable fs qui est mon plus gros soucis :
Option Explicit
Public P_RAN1, P_GRO As String
Public P_FIL1 As String, P_FIL2 As String, P_FIL3 As String
Sub H_ACCess1b(v_ver As Byte, X As String, V_continu As Byte, _
V_formule As Byte)
If V_continu = 2 And Range("M_CONT_B") = 1 And Range("M_CIR") = 2 Then
Set P_RAN1 = Range("M" & Range("M_CIR") & "_MAR2")
Else: Set P_RAN1 = Range("M" & Range("M_CIR") & "_MAR1")
End If
Application.SheetsInNewWorkbook = 1
Application.ScreenUpdating = False
Dim Db_1 As Byte, Db_2 As Byte
Dim Di_1 As Integer, Di_2 As Integer, Di_3 As Integer, Di_4 As Integer
Dim Ds_1 As String, Ds_2 As String
Dim fs, uf1_l1
Dim F_FIL As String
Dim i_cum As Integer
Range("M_1_DATA").Cells(1, 1).Value = X
Range("M_" & v_ver & "_DATA3").Copy
Range("M_1_DATA2").PasteSpecial Paste:=xlPasteValues
uf1_l1 = Range("M_1_DATA1")
UserForm2.ListBox1.List() = uf1_l1
UserForm2.Show
If UserForm2.TextBox1 = 2 Then
MsgBox ("SELECTION ANNULEE")
End
End If
If Range("M_MD1") <> 1 And V_formule = 2 Then
MsgBox ("SELECTION ANNULEE : PAS DE RECALCUL SUR LES MOIS")
End
End If
Calculate
'-------------------------------------------------------------
Di_3 = 1: Di_4 = 1
If V_continu = 2 Then Di_4 = P_RAN1.Rows.Count
If V_continu = 3 Then
Di_4 = Range("M_MF1")
Di_3 = Range("M_MD1")
End If
'Si Génération en continu
For Di_2 = Di_3 To Di_4
If V_continu = 2 Then Range("M_1_DATA1").Cells(2, 2) = P_RAN1.Cells(Di_2, 1)
Calculate
If V_continu <> 3 Then
P_FIL1 = Range("M_FILE1").Cells(1, Range("M_CIR")) & ".xls"
P_FIL2 = Range("M_FILE2").Cells(1, Range("M_CIR")) & ".xls"
ElseIf V_continu = 3 Then
P_FIL1 = Left(Range("M_FILE1").Cells(1, Range("M_CIR")), 7) & T_T2(Di_2) & ".xls"
P_FIL2 = Left(Range("M_FILE1").Cells(1, Range("M_CIR")), 7) & T_T2(Di_2 - 1) & ".xls"
End If
P_FIL3 = Range("M_FILE3").Cells(1, Range("M_CIR")) & ".xls"
P_GRO = Range("M_GRO").Cells(1, Range("M_CIR"))
'Teste l'existence d'une extraction Db_1 = 2 autrement
'Db_1 = 3 si normal ou 4 si CUMUL
Db_1 = 0
Calculate
Set fs = Application.FileSearch
fs.LookIn = Range("M_DIR2")
fs.Filename = P_FIL1
fs.Execute
If fs.FoundFiles.Count = 1 Then
If UCase(fs.FoundFiles(1)) = UCase(Range("M_DIR2") & "\" & P_FIL1) Then
Db_1 = 2
Else: Db_1 = 3
End If
Else: Db_1 = 3
End If
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Merci par avance pour toute aide meme un petit exemple basé sur ce code.
Pour info, j'ai commencé avec ClFileSearch.Nouvelle_Recherche proposé sur le net mais je bloque sur le fs.
Dim i As Long
Dim Recherche As ClFileSearch.ClasseFileSearch
Dim FileName As String
Set Recherche = ClFileSearch.Nouvelle_Recherche
With Recherche
'Définit le répertoire de recherche
.FolderPath = Range("M_DIR2")
'Définit la recherche dans les sous dossiers (True / False)
.SubFolders = False
'Option de tri:
'(Sort_None, sort_Name, sort_Path, sort_Size, sort_DateCreated, sort_LastModified, sort_Type)
'Pas de tri si le paramètre n'est pas spécifié.
.SortBy = sort_Name
'Option pour rechercher un type de fichier
'(Renvoie tous les fichiers si non spécifié)
'.Extension = "*.doc"
'Execute la recherche
.Execute
'Boucle sur le tableau pour afficher le résultat de la recherche
'(.FoundFilesCount renvoie le nombre de fichiers trouvés)
For i = 1 To .FoundFilesCount
FileName = .Files(i).strFileName 'nom du fichier
' Range("P_FIL1").Value = Filename
' M_DIR2.Value .Files(i).strPathName 'chemin
'If .FoundFilesCount = 1 Then
If UCase(FileName) = UCase(P_FIL1) Then
Db_1 = 2
GoTo suite
Else: Db_1 = 3
End If
'Else: Db_1 = 3
'End If
Next
End With
suite:
Set Recherche = Nothing
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx
'Set fs = Application.FileSearch
'fs.LookIn = Range("M_DIR2")
'fs.Filename = P_FIL1
'fs.Execute
'If fs.FoundFiles.Count = 1 Then
' If UCase(fs.FoundFiles(1)) = UCase(Range("M_DIR2") & "\" & P_FIL1) Then
' Db_1 = 2
'Else: Db_1 = 3
'End If
' Else: Db_1 = 3
'End If
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Merci
Florent
Il y a bien longtemps que je ne suis pas venu sur ce forum, j'en ai d'ailleurs perdu tous mes acces !
Je vous avoue que c'est un sérieux problème (pour moi) qui me fais revenir vers vous (je suis assez interressé sur ce sujet mais j'esperes dépanner un ou deux débutant en échange
Mon problème a déjà abordé dans de nombreux sujets mais je n'arrive pas à appliquer les solutions porposées à mon code.
Pour faire simple, ce code est dans un fichier excel qui va lire dans des fichiers excel pour récupérer des informations.
Ci-dessous un extrait du fameux code qui fonctionnait sous 2003 avec la variable fs qui est mon plus gros soucis :
Option Explicit
Public P_RAN1, P_GRO As String
Public P_FIL1 As String, P_FIL2 As String, P_FIL3 As String
Sub H_ACCess1b(v_ver As Byte, X As String, V_continu As Byte, _
V_formule As Byte)
If V_continu = 2 And Range("M_CONT_B") = 1 And Range("M_CIR") = 2 Then
Set P_RAN1 = Range("M" & Range("M_CIR") & "_MAR2")
Else: Set P_RAN1 = Range("M" & Range("M_CIR") & "_MAR1")
End If
Application.SheetsInNewWorkbook = 1
Application.ScreenUpdating = False
Dim Db_1 As Byte, Db_2 As Byte
Dim Di_1 As Integer, Di_2 As Integer, Di_3 As Integer, Di_4 As Integer
Dim Ds_1 As String, Ds_2 As String
Dim fs, uf1_l1
Dim F_FIL As String
Dim i_cum As Integer
Range("M_1_DATA").Cells(1, 1).Value = X
Range("M_" & v_ver & "_DATA3").Copy
Range("M_1_DATA2").PasteSpecial Paste:=xlPasteValues
uf1_l1 = Range("M_1_DATA1")
UserForm2.ListBox1.List() = uf1_l1
UserForm2.Show
If UserForm2.TextBox1 = 2 Then
MsgBox ("SELECTION ANNULEE")
End
End If
If Range("M_MD1") <> 1 And V_formule = 2 Then
MsgBox ("SELECTION ANNULEE : PAS DE RECALCUL SUR LES MOIS")
End
End If
Calculate
'-------------------------------------------------------------
Di_3 = 1: Di_4 = 1
If V_continu = 2 Then Di_4 = P_RAN1.Rows.Count
If V_continu = 3 Then
Di_4 = Range("M_MF1")
Di_3 = Range("M_MD1")
End If
'Si Génération en continu
For Di_2 = Di_3 To Di_4
If V_continu = 2 Then Range("M_1_DATA1").Cells(2, 2) = P_RAN1.Cells(Di_2, 1)
Calculate
If V_continu <> 3 Then
P_FIL1 = Range("M_FILE1").Cells(1, Range("M_CIR")) & ".xls"
P_FIL2 = Range("M_FILE2").Cells(1, Range("M_CIR")) & ".xls"
ElseIf V_continu = 3 Then
P_FIL1 = Left(Range("M_FILE1").Cells(1, Range("M_CIR")), 7) & T_T2(Di_2) & ".xls"
P_FIL2 = Left(Range("M_FILE1").Cells(1, Range("M_CIR")), 7) & T_T2(Di_2 - 1) & ".xls"
End If
P_FIL3 = Range("M_FILE3").Cells(1, Range("M_CIR")) & ".xls"
P_GRO = Range("M_GRO").Cells(1, Range("M_CIR"))
'Teste l'existence d'une extraction Db_1 = 2 autrement
'Db_1 = 3 si normal ou 4 si CUMUL
Db_1 = 0
Calculate
Set fs = Application.FileSearch
fs.LookIn = Range("M_DIR2")
fs.Filename = P_FIL1
fs.Execute
If fs.FoundFiles.Count = 1 Then
If UCase(fs.FoundFiles(1)) = UCase(Range("M_DIR2") & "\" & P_FIL1) Then
Db_1 = 2
Else: Db_1 = 3
End If
Else: Db_1 = 3
End If
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Merci par avance pour toute aide meme un petit exemple basé sur ce code.
Pour info, j'ai commencé avec ClFileSearch.Nouvelle_Recherche proposé sur le net mais je bloque sur le fs.
Dim i As Long
Dim Recherche As ClFileSearch.ClasseFileSearch
Dim FileName As String
Set Recherche = ClFileSearch.Nouvelle_Recherche
With Recherche
'Définit le répertoire de recherche
.FolderPath = Range("M_DIR2")
'Définit la recherche dans les sous dossiers (True / False)
.SubFolders = False
'Option de tri:
'(Sort_None, sort_Name, sort_Path, sort_Size, sort_DateCreated, sort_LastModified, sort_Type)
'Pas de tri si le paramètre n'est pas spécifié.
.SortBy = sort_Name
'Option pour rechercher un type de fichier
'(Renvoie tous les fichiers si non spécifié)
'.Extension = "*.doc"
'Execute la recherche
.Execute
'Boucle sur le tableau pour afficher le résultat de la recherche
'(.FoundFilesCount renvoie le nombre de fichiers trouvés)
For i = 1 To .FoundFilesCount
FileName = .Files(i).strFileName 'nom du fichier
' Range("P_FIL1").Value = Filename
' M_DIR2.Value .Files(i).strPathName 'chemin
'If .FoundFilesCount = 1 Then
If UCase(FileName) = UCase(P_FIL1) Then
Db_1 = 2
GoTo suite
Else: Db_1 = 3
End If
'Else: Db_1 = 3
'End If
Next
End With
suite:
Set Recherche = Nothing
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx
'Set fs = Application.FileSearch
'fs.LookIn = Range("M_DIR2")
'fs.Filename = P_FIL1
'fs.Execute
'If fs.FoundFiles.Count = 1 Then
' If UCase(fs.FoundFiles(1)) = UCase(Range("M_DIR2") & "\" & P_FIL1) Then
' Db_1 = 2
'Else: Db_1 = 3
'End If
' Else: Db_1 = 3
'End If
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Merci
Florent