Hucreyi Dosya Ismiyle Karsilastirmak

[Korhan Ayhan]

Merhaba,

#10 nolu mesajımdaki kodu güncelledim.

Revize ettiğiniz dosya isimlerinizde revizyon bilgisini aşağıdaki şekilde yaptığınız sürece kod sonuç üretecektir. Kırmızı renkli bölüm tüm revize yaptığınız dosyalarda aynı şekilde olmalı.

25045-A1110-18-IRF-P-2 R5

 

[assa51]

Merhaba,

#10 nolu mesajımdaki kodu güncelledim.

Revize ettiğiniz dosya isimlerinizde revizyon bilgisini aşağıdaki şekilde yaptığınız sürece kod sonuç üretecektir. Kırmızı renkli bölüm tüm revize yaptığınız dosyalarda aynı şekilde olmalı.

25045-A1110-18-IRF-P-2 R5

Cok tesekkur ediyorum Korhan Bey
Basta sizin ve Levent Bey'in yardimlariyla sonuca ulastim

Emeklerinize saglik

 

[Korhan Ayhan]

Merhaba,

Özel mesaj atarak düzeltilmesini istediğiniz problem için #10 nolu mesajımdaki kodda mavi renkle belirttiğim iki satırı silerek istediğiniz sonuca ulaşabilirsiniz.

 

[assa51]

Merhaba,

Özel mesaj atarak düzeltilmesini istediğiniz problem için #10 nolu mesajımdaki kodda mavi renkle belirttiğim iki satırı silerek istediğiniz sonuca ulaşabilirsiniz.

sordugum soru hucrede olupta klasorde bulunmayan dosyalarada revizyon 0 yaziyordu onu bos gecmesini istemistim

yardimlariniz icin tesekkur ediyorum

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

dediginizi yaptigimda revizyon 0 olanada yok mevcut olmayan dosya da yok yaziyor.

listede olupta klasorde olmayan dosya icin yok yazdirabilir miyiz sadece?

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("C:C").ClearContents
    ReDim Revizyon(0 To 0)
 
    For X = 1 To Cells(Rows.Count, 1).End(3).Row
 
        Dosya = Dir(Dosya_Yolu & "\" & Cells(X, 1) & " R*")
 
        While Dosya <> ""
            DoEvents
            Bul = InStr(UCase(Dosya), " R")
            If Bul > 0 Then
               Veri = Mid(Dosya, Bul + 1, 255)
                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
        ElseIf Dir(Dosya_Yolu & "\" & Cells(X, 1) & ".*") = "" Then
            Cells(X, 3) = "DOSYA YOK"
        Else
            Cells(X, 3) = 0
        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