• DİKKAT

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

Hucreyi Dosya Ismiyle Karsilastirmak

A

assa51

Katılım
13 Mayıs 2010
Mesajlar
22
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Merhaba arkadaslar,

1-2 gundur yapmak istedigim bir olay var ama excel bilgim buna elvermedi.

kisaca anlatmaya calisayim;

A hucresindeki rakamlar aslinda network uzerindeki (veya pc de) bir klasor icinde bulunan pdf uzantili dosyalarin isimleridir. Eger bu dosyalarda hic degisiklik yapilmamissa direk adi eger revizyon yapilmissa revizyon sayisina gore dosya isminin sonuna r1, r2, r3 gibi yazilar ekleniyor (bunu ben yapiyorum)

excelin yapmasini istedigim ise

A hucresindeki dosya ismini AAA klasorunde arayacak ve sonundaki r1, r2 veya r3 gibi ekleri C hucresine yazacak.

Bundaki amac ise B hucresinde kaydi tutulan revizyon numarasinin gercekte C hucresindeki ile ayni olup olmadigini karsilastirmak.

213el2u.jpg


30mmxaf.jpg


konu hakkinda fikriniz veya yardiminiz olursa minnettar kalirim

tesekkurler
 
Aşağıdaki kodu denermisiniz.

Kod: 
Sub karsilastir()
Set yol = CreateObject("Scripting.FileSystemObject")
For a = 2 To [a65536].End(3).Row
For Each dosya In yol.GetFolder("C:\AAA").Files
If InStr(dosya.Name, Cells(a, "a")) > 0 Then
If dosya.Name <> Replace(dosya.Name, Cells(a, "a") & " ", "") Then
Cells(a, "c") = Replace(Replace(Replace(dosya.Name, Cells(a, "a") & " ", ""), ".txt", ""), "r", "")
Else
Cells(a, "c") = 0
End If
Exit For
End If
Next
Next
End Sub
 
@Levent bey gercekten cok tesekkur ediyorum istedigimi temel olarak gerceklestirdi

cikti olarak ise sunu verdi;

18566 0
18567 0 r1
18568 2 r2
18569 3 r3
18570 0 18570
18571 1 r2
18572 2 r2
18573 0 r1
18574 0 18574
 
2 nolu mesajımdaki koda bazı ilaveler yaptım. Bu şekilde deneyiniz.
 
tesekkur ediyorum Levent bey 4 4 luk sonuc verdi

buna eklemek istedigim 1 sey daha cikti simdi malesef

diyelim ki bazi dosyalarin hem revizyon 1i hemde 2si yada tum revizyonlari AAA klasorunde olursa bu durumda sadece son revizyonu cekmesini nasil saglayabiliriz?
 
Kod içindeki "exit for" satırını kaldırarak deneyin.
 
evet kod verimli olarak calisiyor cok tesekkur ediyorum

yaklasik 2000 dosya mevcut her revizyonu icin tek tek aradigi icin gercekte verim alamadim. belkide saatler surecektir.

sanirim ilk once dosya isimlerini hucrelere aktaran daha sonra 2 hucre arasinda karsilastirma yapan bir kod isime daha cok yarayacaktir

neyse tekrar yardimlariniz icin tesekkur ediyorum Levent bey cok sagolun

iyi calismalar diliyorum
 
Merhaba,

Eğer aradığınız klasör içinde çok sayıda dosya varsa DIR komutunu kullanmak daha sağlıklı ve hızlı sonuç verecektir. Forumda bununla ilgili örnekler bulunmaktadır.
 
@Korhan Bey

evet dediginiz banada mantikli geldi ve forumdan Zeki Gürsoy beyin kodlarini buldum

peki sayfa2 ye listeledigim dosya isimlerini @Levent Bey'in gosterdigi yol gibi sayfa 1 dekilerle nasil kiyaslaya bilirim?

Tesekkurler
 
Merhaba,

Aşağıdaki kod ile bir klasör seçip altındaki dosyaları A sütunundaki dosya isimleri ile karşılaştırabilirsiniz.

Kod: 
Option Explicit
 
Sub DOSYA_İSİMLERİNİ_KARŞILAŞTIR()
    Dim Klasör As Object, Dosya_Yolu As String, Dosya As String
    Dim X As Integer, Bul As Byte, Veri As String, Say As Byte
 
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işleminiz iptal edilmiştir !", vbExclamation
        Exit Sub
    End If
 
    Dosya_Yolu = Klasör.Items.Item.Path
    Range("C2:C" & Rows.Count).ClearContents
    ReDim Revizyon(0 To 0)
 
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
 
[COLOR=red]      Dosya = Dir(Dosya_Yolu & "\" & Cells(X, 1) & " R*")[/COLOR]
 
        While Dosya <> ""
            DoEvents
            Bul = InStr(UCase(Dosya), " R")
            If Bul > 0 Then
[COLOR=red]               Veri = Mid(Dosya, Bul + 1, 255)[/COLOR]
                Say = Say + 1
                ReDim Preserve Revizyon(0 To Say)
                Revizyon(Say) = CDbl(RAKAM_AL(Veri))
            End If
            Dosya = Dir
        Wend
 
        If Say > 0 Then
            Cells(X, 3) = Application.WorksheetFunction.Max(Revizyon)
            Erase Revizyon
            Say = 0
[B][COLOR=blue]        Else[/COLOR][/B]
[B][COLOR=blue]            Cells(X, 3) = 0[/COLOR][/B]
        End If
    Next
 
    Set Klasör = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Function RAKAM_AL(Veri)
    Dim X As Integer
 
    For X = 1 To Len(Veri)
        If IsNumeric(Mid(Veri, X, 1)) Then
            RAKAM_AL = RAKAM_AL & Mid(Veri, X, 1)
        End If
    Next
End Function
 
Korhan Bey gercekten cok tesekkur ediyorum hepinize ayri ayri

bu islem daha hizli ve verimli oldu gercekten ve cok guzel calismakta

tek sorun ise eger dosya isimlerinde " r" yerine baska birsey varsa ornegin " rev2" yada " r2(cancel)"

error 13 type mismatch hatasi veriyor

Revizyon(Say) = CDbl(Replace(Veri, ".txt", ""))

ilgili satir yukardakidir.
 
Merhaba,

Siz ilk mesajınızda " r1" , " r2" gibi değerleri ben yazıyorum dediğiniz için kodu bu şekilde düzenlemiştim. Yani dosya isimlerinizi belli bir kural çerçevesinde kullandığınızı düşünmüştüm. Son mesajınızdaki gibi karışık bir yapı mevcutsa %100 sonuç almanız mümkün olmayabilir. Üstteki mesajımdaki kodu güncelledim. Birde bu haliyle denermisiniz.
 
Korhan Bey merhabalar

verdiginiz kodun ciktisi asagidaki gibidir. sanirim birseyleri atladik

tesekkur ediyorum
 
Son düzenleme:
Merhaba,

#10 nolu mesajımdaki koda küçük bir ekleme yaptım. Tekrar denermisiniz.

Kodun düzgün çalışması için dosya isimlerinizde kontrol ettiğimiz " R" ifadesi başka yerde geçmemesi gerekiyor.

Yani aşağıdaki gibi bir dosya adında kod sağlıklı sonuç vermeyebilir.

Duy Ralina R2
 
Korhan Bey,

Evet demek istediginizi ve kodun mantigini biraz anladim fakat bu kezde ciktilarda sorun oluyor.
" R" ifadesinden sonra dosya isminden cekilen veriler uyusmuyor
 
Son düzenleme:
Merhaba,

Uyguladığınız dosyaları sıkıştırıp foruma eklermisiniz. Atladığımız detayı daha rahat görebiliriz.
 
Korhan Bey,

Malesef resimde dikkat ettiginiz uzere herbiri 5MB olan PDF dosyalaridir ve zipleyince boyutlari ayni kaliyor bi ufalma olmuyor
 
Merhaba,

Şöyle yapın.

Bir klasör içine TXT olarak dosyalar oluşturun ve isimlerini sizin PDF dosyalarının isimleri ile aynı yapın. Bu hazırladığnız klasörü ve excel dosyasını foruma ekleyin.
 
binlerce dosya oldugundan hata verenleri inceledim ve birkac ornek olacak sekilde dediginiz gibi ornekler verdim

hata veren satirlari sari renkle highlight ettim
 

Ekli dosyalar

Merhaba,

2. satırdaki 5 değeri doğru gibi görünüyor.

Kod şu mantıkla çalışıyor.

A sütunundaki veriler döngüye alınıyor.
Seçtiğiniz klasör altındaki dosyalar içinde hücredeki dosya aıdyla başlayan dosya isimleri kontrol ediliyor. Sıkıntı burada başlıyor. Çünkü aynı dosya adıyla başlayan birden fazla dosya var.

Örnek;
25045-A1110-18-IRF-P-2 R5
25045-A1110-18-IRF-P-21 R2

Dikkat ettiyseniz kırmızı renkli bölümler eşleşmesine rağmen aslında dosyalar tamamen farklı dosyalardır. Eğer P-21 isimli dosyadaki revizyon bilgisindeki sayısal değer 2 değilde 20 olsaydı excel sayfasında C2 hücresindeki değer 5 yerine 20 olacaktı. Ve sonuç yanlış olacaktı.

Doğru sonuca ulaşmamız için dosya isimlerinizde bir standart olmalıdır.

Ben biraz daha üzerinde düşüneyim. Çözüm bulduğumda dönüş yaparım.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst