Soru GetOpenFilename açıldığında %currentdirectory% de açılması nasıl sağlanır?

[seckinb]

Sub dozimetri_al()
fName = Application.GetOpenFilename("Excel Files (*.xls*), *.xls", , "*")
If fName = "False" Then Exit Sub
Worksheets("Dozimetri").Select
Set hdf = Cells(Rows.count, 1).End(3).Offset(1)
Set w2 = Workbooks.Open(fName)
Set s2 = w2.Sheets(1)
hdf.Resize(, 20).Value = Application.Transpose(s2.Range("B2:B21"))
w2.Close 0
Worksheets("Formlar").Select
End Sub

Merhaba
Dış excel dosyasından veri almaya çalışıyorum. Bunun için gelOpenFilename kullanıyorum.

Varsayılan klasörün dosyanın mevcut olduğu klasör olmasını nasıl sağlarım? Alakasız bir yerde açılıyor 5-10 hamlede dosyanın olduğu "Current Directory" ye ulaşıyorum.

Teşekkürler.

 

[halit3]

Bu kodu bir dene

Sub dozimetri_al()

Dim fd As FileDialog

Set fd = Application.FileDialog(msoFileDialogOpen)
fd.InitialFileName = ThisWorkbook.Path

Dim FileChosen As Integer
FileChosen = fd.Show
fd.Title = "Dosya Penceresi"
fd.Filters.Clear
fd.Filters.Add "Excel Files", "*.xls"
fd.FilterIndex = 1
fd.ButtonName = "Dosyayı Aç"
If FileChosen <> -1 Then

Else

Worksheets("Dozimetri").Select
Set hdf = Cells(Rows.Count, 1).End(3).Offset(1)
Set w2 = Workbooks.Open(fd.SelectedItems(1))
Set s2 = w2.Sheets(1)
hdf.Resize(, 20).Value = Application.Transpose(s2.Range("B2:B21"))
w2.Close 0
Worksheets("Formlar").Select

End If
End Sub

 

[Haluk]

Alternatif olarak, kodun başına aşağıdaki "kırmızı" renkli satırı ekleyip, deneyebilirsiniz...

Sub dozimetri_al()
ChDir ThisWorkbook.Path
fName = Application.GetOpenFilename("Excel Files (*.xls*), *.xls", , "*")
If fName = False Then Exit Sub
Worksheets("Dozimetri").Select
Set hdf = Cells(Rows.Count, 1).End(3).Offset(1)
Set w2 = Workbooks.Open(fName)
Set s2 = w2.Sheets(1)
hdf.Resize(, 20).Value = Application.Transpose(s2.Range("B2:B21"))
w2.Close 0
Worksheets("Formlar").Select
End Sub

.

 

[seckinb]

ChDir ThisWorkbook.Path

bunu çalıştıramadım, diğer kod çalıştı.

teşekkürler

 

[Haluk]

Kodu yazdıktan sonra dosyayı kaydettiniz mi?

Çalıştıramadığınız zaman aldığınız hata mesajı nedir ?

.

 

[Haluk]

Değişik disk bölümlerinde çalışıyorsanız, belki ondan dolayı problem olabilir.

Aşağıdaki şekliyle bende bir sorun gözükmüyor....

Sub dozimetri_al()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set drive = FSO.GetDrive(FSO.GetDriveName(ThisWorkbook.FullName))
    ChDrive drive.DriveLetter
    ChDir ThisWorkbook.Path
    fName = Application.GetOpenFilename("Excel Files (*.xls*), *.xls", , "*")
    If fName = False Then Exit Sub
    Worksheets("Dozimetri").Select
    Set hdf = Cells(Rows.Count, 1).End(3).Offset(1)
    Set w2 = Workbooks.Open(fName)
    Set s2 = w2.Sheets(1)
    hdf.Resize(, 20).Value = Application.Transpose(s2.Range("B2:B21"))
    w2.Close 0
    Worksheets("Formlar").Select
End Sub

.

 

[seckinb]

Değişik disk bölümlerinde çalışıyorsanız, belki ondan dolayı problem olabilir.

Aşağıdaki şekliyle bende bir sorun gözükmüyor....

Sub dozimetri_al()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set drive = FSO.GetDrive(FSO.GetDriveName(ThisWorkbook.FullName))
    ChDrive drive.DriveLetter
    ChDir ThisWorkbook.Path
    fName = Application.GetOpenFilename("Excel Files (*.xls*), *.xls", , "*")
    If fName = False Then Exit Sub
    Worksheets("Dozimetri").Select
    Set hdf = Cells(Rows.Count, 1).End(3).Offset(1)
    Set w2 = Workbooks.Open(fName)
    Set s2 = w2.Sheets(1)
    hdf.Resize(, 20).Value = Application.Transpose(s2.Range("B2:B21"))
    w2.Close 0
    Worksheets("Formlar").Select
End Sub

.

bu şekilde tekrarlı kullanımlarda da kusursuz çalışıyor.

ThisWorkbook.Path & "\dosya\"

şeklinde hedefi modifiye ettim bu arada.