open file from folder save in new folder

I have this code and I want it to open a file in a directory that I choose (it does that already), and then I wunt it to create a sub-folder in the folder I chose with the original folders name plus a number. (example) I choose a folder named project_test then it converts the file, in the folder, detail.htm to detail.htm.wk4. Then it creates the sub-folder project_test0001 then saves detail.htm.wk4 in it. Then the next time I run ConvertFiles ,when it creates the sub-folder, it creates project_test0002, and when it has reached the tenth time it creates it as project_test0010 etc.

Please Login or Register  to view this content.

Backup the workbooks before testing this macro

Excel version I have is 2000 so couldnot test the macro



Sub ConvertFiles()
'
'
Application.DisplayAlerts = False
Dim T As Integer
'
T = 1
Dim vrtSelectedItem As Variant

Dim FileToOpen As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Cool Application"
fd.InitialFileName = "Working"
If fd.Show = -1 Then
For a = 1 To fd.SelectedItems.Count
MsgBox fd.SelectedItems(a)
Dim NextFile As String
T = 1

NextFile = Dir(fd.SelectedItems(a) & "\*detail*.htm")
Do While NextFile <> ""
Workbooks.Open Filename:=NextFile

If T < 10 Then
MkDir ActiveWorkbook.Path & "\ PROJECT_TEST000" & T
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\ PROJECT_TEST000" & T & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Else
MkDir ActiveWorkbook.Path & "\ PROJECT_TEST00" & T
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\ PROJECT_TEST00" & T & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End If
ActiveWorkbook.Save
ActiveWorkbook.Close
NextFile = Dir()
T = T + 1

Loop
Next
End If

Application.DisplayAlerts = True


End Sub

Backup your workbooks before using this macro
Try this macro

Sub ConvertFiles()
'
'
Application.DisplayAlerts = False
Dim T As Integer
'
T = 1
Dim vrtSelectedItem As Variant

Dim FileToOpen As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Cool Application"
fd.InitialFileName = "Working"
If fd.Show = -1 Then
For a = 1 To fd.SelectedItems.Count
MsgBox fd.SelectedItems(a)
Dim NextFile As String
T = 1

NextFile = Dir(fd.SelectedItems(a) & "\*detail*.htm")
Dim ar1, ar2 As Variant
ar1 = Split(fd.SelectedItems(a), "\")
ar2 = ar1(UBound(ar1))
Do While NextFile <> ""
Workbooks.Open Filename:=NextFile

If T < 10 Then
MkDir ActiveWorkbook.Path & "\" & ar2 & "000" & T
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\" & ar2 & "000" & T & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Else
MkDir ActiveWorkbook.Path & "\" & ar2 & "00" & T
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\" & ar2 & "00" & T & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End If
ActiveWorkbook.Save
ActiveWorkbook.Close
NextFile = Dir()
T = T + 1

Loop
Next
End If

Application.DisplayAlerts = True


End Sub

I added 1 more function to the end



Sub ConvertFiles()
'
'
Dim temp, temp1, temp2, temp3, temp4 As Variant
Application.DisplayAlerts = False
Dim t As Integer
'
t = 1
Dim vrtSelectedItem As Variant

Dim FileToOpen As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Cool Application"
fd.InitialFileName = "Working"
If fd.Show = -1 Then
For a = 1 To fd.SelectedItems.Count
Dim NextFile As String
t = 1

NextFile = Dir(fd.SelectedItems(a) & "\*detail*.htm")
Dim ar1, ar2 As Variant
ar1 = Split(fd.SelectedItems(a), "\")
ar2 = ar1(UBound(ar1))
temp = last_filename(ActiveWorkbook.Path & "\", ar2)
temp1 = Split(temp, ar2)
temp2 = CInt(temp1(1))
temp3 = temp1 + 1
temp4 = Format(temp3, "000#")
MkDir ActiveWorkbook.Path & "\" & ar2 & temp4
Do While NextFile <> ""
Workbooks.Open Filename:=NextFile
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\" & ar2 & temp4 & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
NextFile = Dir()
t = t + 1

Loop
Next
End If

Application.DisplayAlerts = True


End Sub


Function last_filename(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
t = Dir()
If (t <> "") Then
t1 = t
End If
Wend
If t1 = "" Then
t1 = t
End If
last_filename = t1
End Function

I got an error (see below)



Sub ConvertFiles()
'
'
Dim temp, temp1, temp2, temp3, temp4 As Variant
Application.DisplayAlerts = False
Dim t As Integer
'
t = 1
Dim vrtSelectedItem As Variant

Dim FileToOpen As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Cool Application"
fd.InitialFileName = "Working"
If fd.Show = -1 Then
For a = 1 To fd.SelectedItems.Count
Dim NextFile As String
t = 1

NextFile = Dir(fd.SelectedItems(a) & "\*detail*.htm")
Dim ar1, ar2 As Variant
ar1 = Split(fd.SelectedItems(a), "\")
ar2 = ar1(UBound(ar1))
temp = last_filename(ActiveWorkbook.Path & "\", ar2)
temp1 = Split(temp, ar2)
temp2 = CInt(temp1(1)) <-------------------------------------------Run-time error '9': subscript out of range
temp3 = temp1 + 1
temp4 = Format(temp3, "000#")
MkDir ActiveWorkbook.Path & "\" & ar2 & temp4
Do While NextFile <> ""
Workbooks.Open Filename:=NextFile
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\" & ar2 & temp4 & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
NextFile = Dir()
t = t + 1

Loop
Next
End If

Application.DisplayAlerts = True


End Sub


Function last_filename(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
t = Dir()
If (t <> "") Then
t1 = t
End If
Wend
If t1 = "" Then
t1 = t
End If
last_filename = t1
End Function

Backup the workbooks before using the macros.

Since I don't have excel 2002, i am not testing the code before pasting it.


Sub ConvertFiles()
'
'
Dim temp, temp1, temp2, temp3, temp4 As Variant
Application.DisplayAlerts = False
Dim t As Integer
'
t = 1
Dim vrtSelectedItem As Variant

Dim FileToOpen As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Cool Application"
fd.InitialFileName = "Working"
If fd.Show = -1 Then
For a = 1 To fd.SelectedItems.Count
Dim NextFile As String
t = 1

NextFile = Dir(fd.SelectedItems(a) & "\*detail*.htm")
Dim ar1, ar2 As Variant
ar1 = Split(fd.SelectedItems(a), "\")
ar2 = ar1(UBound(ar1))
temp = last_filename(ActiveWorkbook.Path & "\", ar2)
temp1 = Split(temp, ar2)
on error resume next
temp2 = CInt(temp1(1))
if err.description<>"" then
err.clear
temp3=1
temp4 = Format(temp3, "000#")
else
temp3 = temp2 + 1
temp4 = Format(temp3, "000#")
end if
MkDir ActiveWorkbook.Path & "\" & ar2 & temp4
Do While NextFile <> ""
Workbooks.Open Filename:=NextFile
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\" & ar2 & temp4 & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
NextFile = Dir()
t = t + 1

Loop
Next
End If

Application.DisplayAlerts = True


End Sub


Function last_filename(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
t = Dir()
If (t <> "") Then
t1 = t
End If
Wend
If t1 = "" Then
t1 = t
End If
last_filename = t1
End Function

the code dosen't work
1. it doesn't save as a wk4 file
2. it doesn't create a sub-folder
3. it goes in a constant loop of opening the same file and closeing it over and over again

mabye it's because of the runtime error that poped up earlier(it doesn't anymore though)

try it now

Sub ConvertFiles()
'
'
Dim temp, temp1, temp2, temp3, temp4 As Variant
Application.DisplayAlerts = False
Dim t As Integer
'
t = 1
Dim vrtSelectedItem As Variant

Dim FileToOpen As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Cool Application"
fd.InitialFileName = "Working"
If fd.Show = -1 Then
For a = 1 To fd.SelectedItems.Count
Dim NextFile As String
t = 1

NextFile = Dir(fd.SelectedItems(a) & "\*detail*.htm")
Dim ar1, ar2 As Variant
ar1 = Split(fd.SelectedItems(a), "\")
ar2 = ar1(UBound(ar1))
temp = last_filename(fd.SelectedItems(a) & "\", ar2)
temp1 = Split(temp, ar2)
on error resume next
temp2 = CInt(temp1(1))
if err.description<>"" then
err.clear
temp3=1
temp4 = Format(temp3, "000#")
else
temp3 = temp2 + 1
temp4 = Format(temp3, "000#")
end if
MkDir fd.SelectedItems(a) & "\" & ar2 & temp4
Do While NextFile <> ""
Workbooks.Open Filename:=NextFile
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\" & ar2 & temp4 & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
NextFile = Dir()
t = t + 1

Loop
Next
End If

Application.DisplayAlerts = True


End Sub


Function last_filename(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
t = Dir()
If (t <> "") Then
t1 = t
End If
Wend
If t1 = "" Then
t1 = t
End If
last_filename = t1
End Function

it's good but it only creates the sub-folder one time
(example) I run ConvertFiles and it creates project_test0001 and puts the converted files in it. the second time I run ConvertFiles it doesn't make project_test0002 and puts the converted files in project_test0001

also at the end it goes in a continuous loop of opening the same "detail" files and saving them over and over again


Sub ConvertFiles()
'
'
Dim temp, temp1, temp2, temp3, temp4 As Variant
Application.DisplayAlerts = False
Dim t As Integer
'
t = 1
Dim vrtSelectedItem As Variant

Dim FileToOpen As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Cool Application"
fd.InitialFileName = "Working"
If fd.Show = -1 Then
For a = 1 To fd.SelectedItems.Count
Dim NextFile As String
t = 1

NextFile = Dir(fd.SelectedItems(a) & "\*detail*.htm")
Dim ar1, ar2 As Variant
ar1 = Split(fd.SelectedItems(a), "\")
ar2 = ar1(UBound(ar1))
temp = last_filename(fd.SelectedItems(a) & "\", ar2)
temp1 = Split(temp, ar2)
on error resume next
temp2 = CInt(temp1(1))
if err.description<>"" then
err.clear
temp3=1
temp4 = Format(temp3, "000#")
else
temp3 = temp2 + 1
temp4 = Format(temp3, "000#")
end if
MkDir fd.SelectedItems(a) & "\" & ar2 & temp4
Do While NextFile <> ""
Workbooks.Open Filename:=NextFile
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\" & ar2 & temp4 & "\" & ActiveWorkbook.Name & ".wk4", _ <----------------(it keeps looping here)
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
NextFile = Dir()
t = t + 1

Loop
Next
End If

Application.DisplayAlerts = True


End Sub


Function last_filename(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
t = Dir()
If (t <> "") Then
t1 = t
End If
Wend
If t1 = "" Then
t1 = t
End If
last_filename = t1
End Function

The code was not compatible in excel 2000, so had to change it make it compatilbe to excel 2000

macro does:

1) open file dialog
2) go to file folder and select all the files you want to copy into new created subfolder and click open.
3) creates new subfolder and copies selected files into new folder
4) next time you execute the macro, it would create subfolder like project_file0001 then project_file0002 .......



Sub ListFilesInFolder()
Dim teMp, temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, temp10, FILE_PATH As Variant
t = Application.GetOpenFilename(FileFilter:="HTML files (*.html), *.htm", FilterIndex:=2, MultiSelect:=True)
If UBound(t) > 0 Then
teMp = Split(t(1), "\")
temp1 = teMp(UBound(teMp))
temp2 = Split(t(1), temp1)
temp3 = temp2(0)
temp4 = Split(temp3, "\")
temp5 = temp4(UBound(temp4) - 1)
temp6 = last_filename(temp3, temp5)
If temp6 <> "" Then
temp10 = Split(temp6, temp5)
temp7 = CInt(temp10(1))
End If
If Err.Description <> "" Then
temp8 = 1
temp9 = Format(temp8, "000#")
Else
temp8 = temp7 + 1
temp9 = Format(temp8, "000#")
End If
MkDir temp3 & temp5 & temp9
For I = 1 To UBound(t)
Application.DisplayAlerts = False
Workbooks.OpenText t(I)
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\" & temp5 & temp9 & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next
End If
End Sub
Function last_filename(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
If (t <> "") Then
t1 = t
End If
t = Dir()
Wend
If t1 = "" Then
t1 = t
End If
last_filename = t1
End Function

I works great, but there's one thing that I want. at the begining of the code instead of you choosing the folder and the files in it,you choose the folder and the program atuomaticly gets all the files that has the word "detail" in it (like the code did originally), but otherwise it works great. Thank you for helping me. I really appreciate it.

Back up your workbook before executing this macro.

This is completely different solution, when you execute the macro it will not popup filedialog , the macro will go to folder specified by "path" variable and opens files like *detail*.htm, and does samething as the previous macro.







Sub ListFilesInFolder()
Dim teMp, temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, temp10, FILE_PATH As Variant
Dim c As Integer
Dim t1(20) As Variant
Application.DisplayAlerts = False
Dim path As Variant
path = "C:\Documents and Settings\Administrator\Desktop\webpages\" 'path from which files will be extracted to should end with "\"
t = Dir(path & "*detail*.htm")
Dim c1 As Integer
While t <> ""
t1(c1) = t
t = Dir()
c1 = c1 + 1
Wend
c = 0
For i = 0 To 20
If t1(i) = "" Then
GoTo a:
End If
If c = 0 Then
temp3 = path
temp4 = Split(temp3, "\")
temp5 = temp4(UBound(temp4) - 1)
temp6 = lastest_folder(temp3, temp5) 'finds the latest folder that was created
If temp6 <> "" Then
temp10 = Split(temp6, temp5)
temp7 = CInt(temp10(1))
End If
If Err.Description <> "" Then
temp8 = 1
temp9 = Format(temp8, "000#")
Else
temp8 = temp7 + 1
temp9 = Format(temp8, "000#")
End If
MkDir temp3 & temp5 & temp9
c = 1
End If
Application.DisplayAlerts = False
Workbooks.OpenText path & t1(i)
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.path & "\" & temp5 & temp9 & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Next
a:
Application.DisplayAlerts = True
End Sub
Function lastest_folder(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
If (t <> "") Then
t1 = t
End If
t = Dir()
Wend
If t1 = "" Then
t1 = t
End If
last_filename = t1
End Function

it does nothing for some reason

Sub ListFilesInFolder()
Dim teMp, temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, temp10, FILE_PATH As Variant
Dim c As Integer
Dim t1(20) As Variant
Application.DisplayAlerts = False
Dim path As Variant
path = "C:\Documents and Settings\Administrator\Desktop\webpages\" <-------I don't want it to go there. I want to choose Where it goes
t = Dir(path & "*detail*.htm")
Dim c1 As Integer
While t <> ""
t1(c1) = t
t = Dir()
c1 = c1 + 1
Wend
c = 0
For i = 0 To 20
If t1(i) = "" Then
GoTo a:
End If
If c = 0 Then
temp3 = path
temp4 = Split(temp3, "\")
temp5 = temp4(UBound(temp4) - 1)
temp6 = lastest_folder(temp3, temp5) 'finds the latest folder that was created
If temp6 <> "" Then
temp10 = Split(temp6, temp5)
temp7 = CInt(temp10(1))
End If
If Err.Description <> "" Then
temp8 = 1
temp9 = Format(temp8, "000#")
Else
temp8 = temp7 + 1
temp9 = Format(temp8, "000#")
End If
MkDir temp3 & temp5 & temp9
c = 1
End If
Application.DisplayAlerts = False
Workbooks.OpenText path & t1(i)
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.path & "\" & temp5 & temp9 & "\" & ActiveWorkbook.Name & ".xls", _
FileFormat:=xlExcel7, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Next
a:
Application.DisplayAlerts = True
End Sub
Function lastest_folder(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
If (t <> "") Then
t1 = t
End If
t = Dir()
Wend
If t1 = "" Then
t1 = t
End If
last_filename = t1
End Function

paste your code,

did you change the path variable value

a. do you mean this code
b. no I dont think so

Sub ConvertFiles()
'
'
Application.DisplayAlerts = False

'
Dim vrtSelectedItem As Variant

Dim FileToOpen As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Cool Application"
fd.InitialFileName = "Working"
If fd.Show = -1 Then
For a = 1 To fd.SelectedItems.Count
MsgBox fd.SelectedItems(a)
Dim NextFile As String


NextFile = Dir(fd.SelectedItems(a) & "\*detail*.htm")
Do While NextFile <> ""
Workbooks.Open Filename:=NextFile
ActiveWorkbook.SaveAs Filename:= _
NextFile & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
NextFile = Dir()


Loop
Next
End If

Application.DisplayAlerts = True


End Sub

No I mean the code that you tested and it didnot do anything

its on the the post before you say to post it (post #16)

Try this macro now

1) it will popup with filedialog, select the folder where the detail*.htm files are there, click ok, rest should work same as before

Sub ListFilesInFolder()
Dim teMp, temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, temp10, FILE_PATH As Variant
Dim c As Integer
Dim t1(20) As Variant
Application.DisplayAlerts = False
Dim path As Variant
path = PickFolder("C:\") & "\"
t = Dir(path & "*detail*.htm")
Dim c1 As Integer
While t <> ""
t1(c1) = t
t = Dir()
c1 = c1 + 1
Wend
c = 0
For i = 0 To 20
If t1(i) = "" Then
GoTo a:
End If
If c = 0 Then
temp3 = path
temp4 = Split(temp3, "\")
temp5 = temp4(UBound(temp4) - 1)
temp6 = lastest_folder(temp3, temp5) 'finds the latest folder that was created
If temp6 <> "" Then
temp10 = Split(temp6, temp5)
temp7 = CInt(temp10(1))
End If
If Err.Description <> "" Then
temp8 = 1
temp9 = Format(temp8, "000#")
Else
temp8 = temp7 + 1
temp9 = Format(temp8, "000#")
End If
MkDir temp3 & temp5 & temp9
c = 1
End If
Application.DisplayAlerts = False
Workbooks.OpenText path & t1(i)
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.path & "\" & temp5 & temp9 & "\" & ActiveWorkbook.Name & ".wk4", _
FileFormat:=xlWK4, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Next
a:
Application.DisplayAlerts = True
End Sub
Function lastest_folder(p As Variant, ar2 As Variant)
Dim t1 As Variant
t = Dir(p & ar2 & "*.*", vbDirectory)
While t <> ""
If (t <> "") Then
t1 = t
End If
t = Dir()
Wend
If t1 = "" Then
t1 = t
End If
lastest_folder = t1
End Function
Function PickFolder(strStartDir As Variant) As String
Application.DisplayAlerts = False
Dim SA As Object, f As Object
Set SA = CreateObject("Shell.Application")
Set f = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
If (Not f Is Nothing) Then
PickFolder = f.Items.Item.path
End If
Set f = Nothing
Set SA = Nothing
End Function

thank you very much for helping me