Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Beyin Fırtınası
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Beyin Fırtınası Bu başlıkta, ilginç olduğunu düşündüğünüz sorularınızı, bir problem şeklinde sorabilir, alternatif olduğunu düşündüğünüz çözümlerinizi paylaşabilirsiniz. (Bu başlıkta yeni konu açılması onaya bağlıdır.)
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 09-10-2013, 15:40   #41
soneravci
 
Giriş: 18/06/2013
Mesaj: 39
Excel Vers. ve Dili:
2010 TÜRKÇE
Varsayılan

inanılmaz bir zaman kazancım oldu teşekkür ederim
soneravci Çevrimdışı   Alıntı Yaparak Cevapla
Eski 23-02-2014, 23:12   #42
enisumit
 
Giriş: 10/02/2009
Mesaj: 1
Excel Vers. ve Dili:
vb excel 2010
Varsayılan

bende çok teşekkür ederim gerçekten çok yararlı bir paylaşım olmuş.. ama üstteki kodlara bir eklenti rica edeceğim.. bir türlü yapamadım..listelediğimiz klasörün içinde bulunan excellerde "Bottoms Summary sheet (inch)" adlı bir sheet var. Bu sheetlerin b28'deki değerini, oluşturduğumuz excelin I sütununa yazdırmak istiyorum.. yardımcı olursanız sevinirim...
enisumit Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-03-2014, 08:12   #43
cagdaser
Altın Üye
 
cagdaser kullanıcısının avatarı
 
Giriş: 25/02/2008
Şehir: Uşak
Mesaj: 14
Excel Vers. ve Dili:
2010-İngilizce
Varsayılan

Teşekkür ederim arkadaşlar çok işime yaradı
cagdaser Çevrimdışı   Alıntı Yaparak Cevapla
Eski 22-02-2018, 06:03   #44
svorm
 
Giriş: 26/02/2010
Mesaj: 148
Excel Vers. ve Dili:
2007 türkçe
Varsayılan

Merhaba

halit bey elinize bileğinize sağlık. kodlar çok işime yaradı,

Bu mesaj en son " 25-02-2018 " tarihinde saat 20:25 itibariyle svorm tarafından düzenlenmiştir....
svorm Çevrimdışı   Alıntı Yaparak Cevapla
Eski 11-04-2018, 22:03   #45
Noise1903
 
Giriş: 27/01/2012
Şehir: İzmir
Mesaj: 1
Excel Vers. ve Dili:
Office 2007, Türkçe.
Varsayılan

Alıntı:
Bogachank tarafından gönderildi Mesajı Görüntüle
Merhaba,

Alternatif olarak daha önce Haluk, Hamitcan ve Korhan üstatların yardımları ile derlediğim çalışmayı ekte bilgilerinize sunarım.

Bu vesile ile hocalarımıza tekrar teşekkür ederim.

Saygılarımla.

http://www.excel.web.tr/f48/active-d...23/sayfa3.html

Çalışma 1; Aşağıdaki kod seçilen klasördeki dosyaların dosya adlarını, linklerini ve çeşitli özelliklerini sıralamaktadır.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Public ui As Long
Sub SubHsr()
Dim soru As String
10  If Application.Workbooks.Count = 0 Then
11      soru = "Açık Çalışma Kitabı bulunmamaktadır, yeni çalışma kitabı açılsın mı?"
12      If MsgBox(soru, vbYesNo) = vbYes Then
13          Workbooks.Add: GoTo 18
14      Else
15          MsgBox "Açık çalışma kitabı olmadığından çıklacaktır": GoTo 117
16      End If
17  Else
18      soru = ActiveWorkbook.Name & " kitabının " & ActiveSheet.Name
19      soru = soru & " sayfasına Dosyalar listelenecektir." & vbLf & "Devam Etmek İstiyormusunuz?"
20      If MsgBox(soru, vbYesNo) = vbYes Then
21          GoTo 101
22      Else
23          GoTo 117
24      End If
25  End If
101    Dim klsrSec As Object
102    Dim klsrMsUstu, Dosya, yol As String
103    Set klsrSec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
104    klsrMsUstu = CreateObject("WScript.Shell").SpecialFolders("Desktop")
105        If klsrSec Is Nothing Then GoTo 117
106        If klsrSec = "Masaüstü" Or Klasor = "Desktop" Then
107            yol = klsrMsUstu
108            AnaListe (yol)
109            AltListe (yol)
110        ElseIf klsrSec <> "Masaüstü" Then
111            yol = klsrSec.Items.Item.Path
112            AnaListe (yol)
113            AltListe (yol)
114        Else
115            GoTo 117
116        End If
117    Set klsrSec = Nothing: ui = 0
End Sub
Private Sub AnaListe(yol As String)
201 Dim Dosya As String
202 Cells.ClearContents
203 Range("A4") = "Dosya Yolu":             Range("B4") = "Dosya Adı"
204 Range("C4") = "Dosya Tipi":             Range("D4") = "Dosya Boyutu"
205 Range("E4") = "Oluşturulma Tarihi":     Range("F4") = "Son Erişim Tarihi"
206 Range("G4") = "Son Düzenleme Tarihi":   Range("H4") = "Son Düzenleme Zamanı"
207 Dosya = Dir(yol & "\*.*")
208 ui = 4
209 While Dosya <> ""
210     DoEvents
211     ui = ui + 1
212     Cells(ui, 1) = yol
213     Cells(ui, 2) = Dosya
214     Call DosyaOzellikleri(yol & Application.PathSeparator & Dosya)
215     Dosya = Dir
216 Wend
End Sub
Private Sub AltListe(yol As String)
On Error Resume Next
301 Dim klsrAra, klsrLst As Object, Dosya, dsyTYl As String
302 Set klsrLst = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
303 On Error GoTo 316
304 For Each klsrAra In klsrLst
305     Dosya = Dir(klsrAra.Path & "\*.*")
306     While Dosya <> ""
307        DoEvents
308        ui = [a65000].End(3).Row + 1
309        Cells(ui, 1) = klsrAra.Path & "\"
310        Cells(ui, 2) = Dosya
311        Call DosyaOzellikleri(klsrAra.Path & Application.PathSeparator & Dosya)
312        Dosya = Dir
313     Wend
314     AltListe (klsrAra.Path)
315 Next
316 Set klsrAra = Nothing: Set klsrLst = Nothing
End Sub
Private Sub DosyaOzellikleri(dsyBak As String)
401 Dim DsSisKnt, Dosyam As Object
402 Set DsSisKnt = CreateObject("Scripting.FileSystemObject")
403 Set Dosyam = DsSisKnt.GetFile(dsyBak)
404 With Dosyam
405    ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & ui), Address:=dsyBak
406    Range("C" & ui) = .Type
407    Range("D" & ui) = Format(.Size / 1024, "#,##0.0000") & " Kb"
408    Range("E" & ui) = Format(.DateCreated, "dd.mm.yyyy")
409    Range("F" & ui) = Format(.DateLastAccessed, "dd.mm.yyyy")
410    Range("G" & ui) = Format(.DateLastModified, "dd.mm.yyyy")
411    Range("H" & ui) = Format(.DateLastModified, "hh:mm:ss")
412 End With
413 Set DsSisKnt = Nothing
414 Set Dosyam = Nothing
End Sub
Çalışma 2; Bu kodda ise seçilen yerdeki dosyaların yolunu manuel yazmakla beraber devamında gelen ekranda istediğimiz uzantı tipini ( *.* ; *.xls ; *.doc ; vs... ) şeklinde yazarak arama için uzantı kıstası oluşturabilmekteyiz.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub Listele()
Dim DTipi$, Klasor$
Klasor = InputBox(" ÖNEMLİ ! : Bulunan değerleri seçili hücreden aşağı doğru yapacağından, doğru sayfa ve doğru hücreyi seçtiğinizden emin olun. Eğer emin değilseniz Cancele basıp çıkın eminseniz, Aşağıya veri girebilirsiniz. " & Chr(13) & "     " & Chr(13) & "Listelenecek yolu yazınız." & Chr(13) & " " & Chr(13) & " Örneğin " & Chr(13) & " D:  " & Chr(13) & "   veya   " & Chr(13) & " C:\Documents and Settings\mozdem\Desktop  ", "Aranacak Dosyaların Yolu ? ")
If Klasor = "" Then End
DTipi = InputBox("Listelenecek dosya türünü yazınız", "Dosya türü ne?", "*.*")
Call ListeAl(Klasor, DTipi, True)
End
End Sub
Sub ListeAl(Klasor$, DTipi$, Alt%)
Dim klasorler(), i, Dosya$, yol$, attr%, ks%
Static r
On Error Resume Next
If Right$(Klasor, 1) <> "\" Then Klasor = Klasor & "\"
If DTipi = "" Then End
Dosya = Dir(Klasor & DTipi, vbNormal)
Do While Dosya <> ""
        yol = Klasor & Dosya
        ActiveCell.Offset(r, 0) = yol
        r = r + 1
        Dosya = Dir()
Loop
If Alt = False Then Exit Sub
Dosya = Dir(Klasor & "*.*", vbDirectory)
Do While Dosya <> ""
    attr = 0
    attr = GetAttr(Klasor & Dosya)
    If Dosya <> "." And Dosya <> ".." And _
        (attr And vbDirectory) <> 0 _
    Then
        ks = ks + 1 'klasör sayısı
        ReDim Preserve klasorler(1 To ks)
        klasorler(ks) = Dosya
    End If
    Dosya = Dir()
Loop

For i = 1 To ks
     Call ListeAl(Klasor & klasorler(i) & "\", DTipi, Alt)
Next i
End Sub
Bu kodlar için çok teşekkür ediyorum, gerçekten çok işime yaradı.

Sadece bir şey daha eklemek istiyorum. Dosyaların boyutu, yaratma tarihi vb. bilgilerin yanında, dosyaların video olduğunu düşünün, video süresini getirmek istiyorum. Bunun için yardımcı olabilen olursa çok sevinirim.

Teşekkürler.
Noise1903 Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 05:12


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım -- Beylikdüzü mali müşavir - Beylikdüzü mali müşavir - Lingerie - Dyeing Machine - Karton Bardak- Karton Bardak- Çorlu Dil Konuşma Terapisti- Çorlu Dil Konuşma Terapisti- Çorlu Konuşma Terapisti- Çorlu Konuşma Terapisti- Çorlu Özel Eğitim- Site Yönetimi- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Çorlu- Çorlu Araç Takip- Rampa- Çorlu İnternet Sitesi- Çorlu Sürücü Kursu- Şişli Avukat- Çorlu Etüt- İstanbul Botanik- Çorlu Sigorta- Kağıt Bardak- Kağıt Bardak- Çorlu Havuz- Çorlu Havuz- Çorlu Perde Yıkama- Okul Danışmanlık- ADR'li taşıma kabı imalatı- Mekanik Tesisat- Çorlu Grafik Tasarım- Çorlu Sondaj- Çorlu Etüt- Futbol Cafe- Beylikdüzü Temizlik- Çorlu Kurs- Çorlu Ders- İzmit Mimar- Hurda Bakır Kablo- Hurda Bakır Kablo- Çorlu Pronet- Çorlu Yönetim- Çorlu Apartman Yönetimi- Çorlu Marangoz- Çorlu Avukat-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden