• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

ThisWorkbook.Path

  • Konbuyu başlatan Konbuyu başlatan usta07
  • Başlangıç tarihi Başlangıç tarihi
U

usta07

Destek Ekibi
Destek Ekibi
Katılım
30 Mart 2008
Mesajlar
405
Excel Vers. ve Dili
2003 Türkçe
Sayın Halit ÖZDEMİR,
Tarafından yazılan Aşağıdaki KOD da mevcut olan "Yol", "Klasör" isimlerinin seçme seçeneğini
"ThisWorkbook.Path & "\*.xls" olarak nasıl sabit hale getirebiliriz. Ayrıca biraz yavaş çalışıyor hızlandırma şansımız varmıdır?
Yardımcı olabilecek uzman arkadaşlara şimdiden teşekkür ederim.

Kod: 
Private Sub Image1_Click()
a = MsgBox("BÖLGE DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo, "Excel.Web.tr")
If a = vbNo Then
Exit Sub
End If
sat = 2 'Cells(Columns.Count,"A").End(3).Row + 1
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
On Error Resume Next
Dim Baslik As String
Baslik = "BÖLGE DOSYALARINI İÇEREN KLASÖRÜ SEÇİNİZ"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.browseforfolder(0, Baslik, 50, &H0)
Kaynak = Klasor.Items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
Liste (Klasor.Items.Item.Path)
MsgBox "VERİ GÜNCELLEME TAMAM", , "Excel.Web.tr"
Else
Atla:
MsgBox "LUTFEN KLASÖR SEÇİMİ YAPINIZ !", , "Excel.Web.tr"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

Private Sub Liste(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Yol).SubFolders
Dim wb As Workbook
Dosya = Dir(Yol & "\*.*")
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
tmp = Dosya
deg = "'" & Kaynak & "\" & "[" & tmp & "]" & "W1011" & "'!R" '//Veri alınacak dosyalardaki sayfa isimleri aynı olacak
For r = 2 To 500
For i = 1 To 41
Cells(sat, i) = ExecuteExcel4Macro(deg & r & "C" & i)
If Cells(sat, i) = 0 Then
Cells(sat, i) = ""
End If
Next i
sat = Cells(Rows.Count, "A").End(3).Row + 1 
Next r
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub
 
böyle denermisiniz.

Private Sub Image1_Click()
a = MsgBox("BÖLGE DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo, "Excel.Web.tr")
If a = vbNo Then
Exit Sub
End If
sat = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Liste (ThisWorkbook.Path)
MsgBox "VERİ GÜNCELLEME TAMAM", , "Excel.Web.tr"
End Sub
Genişletmek için tıkla ...
 
Halit Bey,
Aşağıdaki Kod ile "VERİ GÜNCELLEME TAMAM" mesajı veriyor ancak hiç veri almıyor.

Kod: 
Private Sub Image1_Click()
a = MsgBox("BÖLGE DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo, "Excel.Web.tr")
If a = vbNo Then
Exit Sub
End If
sat = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Liste (ThisWorkbook.Path)
MsgBox "VERİ GÜNCELLEME TAMAM", , "Excel.Web.tr"
End Sub
Private Sub Liste(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Yol).SubFolders
Dim wb As Workbook
Dosya = Dir(Yol & "\*.xls")
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
tmp = Dosya
deg = "'" & Kaynak & "\" & "[" & tmp & "]" & "W1011" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
For r = 2 To 500
For i = 1 To 41
Cells(sat, i) = ExecuteExcel4Macro(deg & r & "C" & i)
If Cells(sat, i) = 0 Then
Cells(sat, i) = ""
End If
Next i
sat = Cells(Rows.Count, "A").End(3).Row + 1 'sat + 1
Next r
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub
 
Klasorü bulamıyor ondan birde bunu denermisiniz.

Private Sub Image1_Click()
a = MsgBox("BÖLGE DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo, "Excel.Web.tr")
If a = vbNo Then
Exit Sub
End If
sat = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Liste (ThisWorkbook.Path)
MsgBox "VERİ GÜNCELLEME TAMAM", , "Excel.Web.tr"
End Sub
Private Sub Liste(Kalasor As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Kalasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Kalasor & "\*.xls")
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
deg = "'" & Kalasor & "\" & "[" & Dosya & "]" & "W1011" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
For r = 2 To 500
For i = 1 To 41
Cells(sat, i) = ExecuteExcel4Macro(deg & r & "C" & i)
If Cells(sat, i) = 0 Then
Cells(sat, i) = ""
End If
Next i
sat = Cells(Rows.Count, "A").End(3).Row + 1 'sat + 1
Next r
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
 
Halit Bey,
SharePoint Portal 2003 de kullanınca aşağıdaki satırda hata verdi
SharePoint 2003 e uyumlu kod varmıdır. Size de zahmet veriyoruz.

Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Kalasor).SubFolders
 
usta07' Alıntı:
Halit Bey,
SharePoint Portal 2003 de kullanınca aşağıdaki satırda hata verdi
SharePoint 2003 e uyumlu kod varmıdır. Size de zahmet veriyoruz.

Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Kalasor).SubFolders
Genişletmek için tıkla ...

bu konuda bilgim yok kusura bakmayınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst