J'ai 2 fois la même macro la seul différence c'Est qu'une permet de choisir le répertoire dans lequel ce trouve les fichiers et pour l'autre macro le répertoire est fixe. Quand j'utilise la fonction activesheet.name dans la macro ou le répertoire est déja déterminé ca fonctionne mais quand j'utilise l'autre macro qui permet de choisir le répertoire activesheet.name ne fonctionne plus. Ca fait des heures que je cherche l'erreur mais je trouve pas.
Donc voici la copie des 2 macros
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib 'shell32.dll' _
Alias 'SHGetPathFromIDListA' (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib 'shell32.dll' _
Alias 'SHBrowseForFolderA' (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = 'Select a folder.'
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Range('a2') = GetDirectory
Else
GetDirectory = ''
End If
End Function
Sub Lecture_Resis()
Set fichcherche = Application.FileSearch
With fichcherche
.LookIn = GetDirectory
.Filename = '*.z'
If .Execute > 0 Then
MsgBox .FoundFiles.Count & 'Fichiers ont été trouvés'
Workbooks.Add
For I = 1 To .FoundFiles.Count
Workbooks.OpenText Filename:=.FoundFiles(I), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1)
Rows('1:3').Select
Selection.Delete Shift:=xlUp
Rows('3:136').Select
Selection.Delete Shift:=xlUp
Rows('4:4').Select
Selection.Delete Shift:=xlUp
Columns('B').Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range('b1') = ActiveSheet.Name
Range('A:C').Select
Selection.Copy
Windows('zview_macro.xls').Activate
Sheets('calcul').Activate
Range('A:C').Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
For Each Wk In Workbooks
If Wk.Name <> ThisWorkbook.Name Then
Wk.Close savechanges:=False
End If
Next Wk
With Worksheets('calcul')
Application.CutCopyMode = True
.Range('o65536').End(xlUp).Offset(1, 0).Value = .Range('a1').Value
.Range('o65536').End(xlUp).Offset(0, 1).Value = .Range('b1').Value
.Range('o65536').End(xlUp).Offset(0, 2).Value = .Range('a2').Value
.Range('o65536').End(xlUp).Offset(0, 3).Value = .Range('m37').Value
.Range('o65536').End(xlUp).Offset(0, 4).Value = .Range('n37').Value
End With
On Error Resume Next
Next I
Else
MsgBox 'Aucun fichier n'a ete trouve'
End If
End With
Sheets('résultats').Select
Columns('A:e').Select
Selection.Sort Key1:=Range('c1'), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets('Macro').Select
Sheets('Macro').Activate
ActiveWindow.SelectedSheets.Visible = False
Sheets('résultats').Select
Range('f1').Select
sPath = Range('f1').Value
If Right(sPath, 1) <> '\\' Then sPath = sPath & '\\'
ActiveWorkbook.SaveAs sPath & ActiveSheet.Range('g1').Value
End Sub
2e macro
Sub Lecture_Resis()
Set fichcherche = Application.FileSearch
With fichcherche
.LookIn = 'C:\\macro'
.Filename = '*.z'
If .Execute > 0 Then
MsgBox .FoundFiles.Count & 'Fichiers ont été trouvés'
Workbooks.Add
For I = 1 To .FoundFiles.Count
Workbooks.OpenText Filename:=.FoundFiles(I), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1)
Rows('1:3').Select
Selection.Delete Shift:=xlUp
Rows('3:136').Select
Selection.Delete Shift:=xlUp
Rows('4:4').Select
Selection.Delete Shift:=xlUp
Columns('B').Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range('b1') = ActiveSheet.Name
Range('A:C').Select
Selection.Copy
Windows('macrotest.xls').Activate
Sheets('calcul').Activate
Range('A:C').Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
For Each Wk In Workbooks
If Wk.Name <> ThisWorkbook.Name Then
Wk.Close savechanges:=False
End If
Next Wk
With Worksheets('calcul')
Application.CutCopyMode = True
.Range('o65536').End(xlUp).Offset(1, 0).Value = .Range('a1').Value
.Range('o65536').End(xlUp).Offset(0, 1).Value = .Range('b1').Value
.Range('o65536').End(xlUp).Offset(0, 2).Value = .Range('a2').Value
.Range('o65536').End(xlUp).Offset(0, 3).Value = .Range('m37').Value
.Range('o65536').End(xlUp).Offset(0, 4).Value = .Range('n37').Value
End With
On Error Resume Next
Next I
Else
MsgBox 'Aucun fichier n'a ete trouve'
End If
End With
Sheets('résultats').Select
Columns('A:e').Select
Selection.Sort Key1:=Range('c1'), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets('Macro').Select
Sheets('Macro').Activate
ActiveWindow.SelectedSheets.Visible = False
Sheets('résultats').Select
Range('A1').Select
ActiveWorkbook.SaveAs Filename:= _
'C:\\macro\\Data.xls' _
, FileFormat:=xlNormal, Password:='', WriteResPassword:='', _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
Message édité par: chemist, à: 02/08/2005 05:55
Donc voici la copie des 2 macros
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib 'shell32.dll' _
Alias 'SHGetPathFromIDListA' (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib 'shell32.dll' _
Alias 'SHBrowseForFolderA' (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = 'Select a folder.'
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Range('a2') = GetDirectory
Else
GetDirectory = ''
End If
End Function
Sub Lecture_Resis()
Set fichcherche = Application.FileSearch
With fichcherche
.LookIn = GetDirectory
.Filename = '*.z'
If .Execute > 0 Then
MsgBox .FoundFiles.Count & 'Fichiers ont été trouvés'
Workbooks.Add
For I = 1 To .FoundFiles.Count
Workbooks.OpenText Filename:=.FoundFiles(I), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1)
Rows('1:3').Select
Selection.Delete Shift:=xlUp
Rows('3:136').Select
Selection.Delete Shift:=xlUp
Rows('4:4').Select
Selection.Delete Shift:=xlUp
Columns('B').Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range('b1') = ActiveSheet.Name
Range('A:C').Select
Selection.Copy
Windows('zview_macro.xls').Activate
Sheets('calcul').Activate
Range('A:C').Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
For Each Wk In Workbooks
If Wk.Name <> ThisWorkbook.Name Then
Wk.Close savechanges:=False
End If
Next Wk
With Worksheets('calcul')
Application.CutCopyMode = True
.Range('o65536').End(xlUp).Offset(1, 0).Value = .Range('a1').Value
.Range('o65536').End(xlUp).Offset(0, 1).Value = .Range('b1').Value
.Range('o65536').End(xlUp).Offset(0, 2).Value = .Range('a2').Value
.Range('o65536').End(xlUp).Offset(0, 3).Value = .Range('m37').Value
.Range('o65536').End(xlUp).Offset(0, 4).Value = .Range('n37').Value
End With
On Error Resume Next
Next I
Else
MsgBox 'Aucun fichier n'a ete trouve'
End If
End With
Sheets('résultats').Select
Columns('A:e').Select
Selection.Sort Key1:=Range('c1'), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets('Macro').Select
Sheets('Macro').Activate
ActiveWindow.SelectedSheets.Visible = False
Sheets('résultats').Select
Range('f1').Select
sPath = Range('f1').Value
If Right(sPath, 1) <> '\\' Then sPath = sPath & '\\'
ActiveWorkbook.SaveAs sPath & ActiveSheet.Range('g1').Value
End Sub
2e macro
Sub Lecture_Resis()
Set fichcherche = Application.FileSearch
With fichcherche
.LookIn = 'C:\\macro'
.Filename = '*.z'
If .Execute > 0 Then
MsgBox .FoundFiles.Count & 'Fichiers ont été trouvés'
Workbooks.Add
For I = 1 To .FoundFiles.Count
Workbooks.OpenText Filename:=.FoundFiles(I), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1)
Rows('1:3').Select
Selection.Delete Shift:=xlUp
Rows('3:136').Select
Selection.Delete Shift:=xlUp
Rows('4:4').Select
Selection.Delete Shift:=xlUp
Columns('B').Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range('b1') = ActiveSheet.Name
Range('A:C').Select
Selection.Copy
Windows('macrotest.xls').Activate
Sheets('calcul').Activate
Range('A:C').Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
For Each Wk In Workbooks
If Wk.Name <> ThisWorkbook.Name Then
Wk.Close savechanges:=False
End If
Next Wk
With Worksheets('calcul')
Application.CutCopyMode = True
.Range('o65536').End(xlUp).Offset(1, 0).Value = .Range('a1').Value
.Range('o65536').End(xlUp).Offset(0, 1).Value = .Range('b1').Value
.Range('o65536').End(xlUp).Offset(0, 2).Value = .Range('a2').Value
.Range('o65536').End(xlUp).Offset(0, 3).Value = .Range('m37').Value
.Range('o65536').End(xlUp).Offset(0, 4).Value = .Range('n37').Value
End With
On Error Resume Next
Next I
Else
MsgBox 'Aucun fichier n'a ete trouve'
End If
End With
Sheets('résultats').Select
Columns('A:e').Select
Selection.Sort Key1:=Range('c1'), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets('Macro').Select
Sheets('Macro').Activate
ActiveWindow.SelectedSheets.Visible = False
Sheets('résultats').Select
Range('A1').Select
ActiveWorkbook.SaveAs Filename:= _
'C:\\macro\\Data.xls' _
, FileFormat:=xlNormal, Password:='', WriteResPassword:='', _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
Message édité par: chemist, à: 02/08/2005 05:55