Dosya adlarını hücreden alma

ASLAN7410 · 23 Şubat 2017

Merhaba hayırlı akşamlar.

Ekte gönderdiğim örnek bir klasör içerisinde çeşitli isimlerle xls ve xlsx uzantılı excel dosyalarım var, bu dosyaların Sayfa1 B26 hücresinde de birbirlerinden farklı numaralar var.

Benim istediğim bu hücredeki numaraları alıp aynı dosyanın ismine yazsın.

Örnek olarak AliVeli isimli bir excel dosyam var, bu dosyanın Sayfa1 B26 hücresindede de 123456789 şeklinde numara var, bu hücredeki numarayı AliVeli isimli excel dosyanının adını 123456789 olarak değiştirsin.

Forumda ve internette araştırdım bu şekilde bir çalışma bulamadım, veri çok olduğu için dosyaları tek tek açıp bu hücredeki numarayı kopyalayıp dosyayı kapatıp, dosyanın ismini manuel değiştiriyorum. İsimleri değişecek dosya sayısı çok olduğu için çok zaman alıyor.

Yardımcı olur musunuz?

http://dosya.co/y8bym95tgmix/DOSYALAR.rar.html
.

dEdE · 23 Şubat 2017

Merhaba,
Aşağıdaki kodu yeni(boş) bir excel dosyasına yapıştırıp dosyayı adını değiştireceğiniz dosyaların bulunduğu klasöre kayıt edip, kodu çalıştırınız.

Kod:

Sub AdDeğiştir()
Application.ScreenUpdating = False
Yol = ThisWorkbook.Path & Application.PathSeparator
Set COfs = CreateObject("Scripting.FileSystemObject")

For Each Dosya In COfs.GetFolder(Yol).Files
Uzantı = COfs.GetExtensionName(Dosya.Name)
If Uzantı = "xls" Or Uzantı = "xlsx" Then
    Set WBook = Workbooks.Open(Yol & Dosya.Name)
    DosyaAdı = WBook.Sheets(1).[B26].Value & "." & Uzantı
    WBook.Close
    Dosya.Name = DosyaAdı
End If
Next
Application.ScreenUpdating = True
MsgBox "Ad Değiştirme İşlemi Tamamlandı. ", vbInformation, "dEdE  " & _
Application.UserName & "'e Başarılar Diler."
End Sub

ASLAN7410 · 23 Şubat 2017

Sayın dEde ilginiz için çok teşekkür ediyorum, sizin dediğiniz gibi yaptım, kodu çalıştırdığım zaman aşağıdaki kodu sarıya boyuyor, hata veriyor, dosya isimlerini de değiştirmiyor.

Kod:

Name Dosya.Name As DosyaAdı

dEdE · 23 Şubat 2017

Merhaba,
İlk mesajınıza eklediğiniz klasör üzerinde yaptığım denemede sorunsuz olarak çalışıyor. Asıl klasörünüz bundan farklı ise sorun çıkabilir.
Örneğin B26 hücresi boş ise, dosya adı alarak kullanılmayan bir karakter içeriyorsa veya farklı dosyaların B26 hücresinde aynı değer varsa(mükerrer dosya adı) sorun çıkabilir.
Eklediğiniz klasör içinde çalıştırarak dener misiniz?

Asri · 23 Şubat 2017

Alternatif;

Boş bir excel dosyasına kaydedin. Bu dosya değiştireceğiniz dosyaların bulunduğu ana klasör de onun altındaki klasörlerde bulunmamalı.

VBA tools reference da Microsoft scripting runtime seçili olmalı.

* Dosya adı uygunsuz karakter içeriyor ise işlem yapmaz
* Tüm hatalı işlemler log sayfasında listelenir. Hatalı dosyalara link verilir.
* Sayfa adı bağımsızdır, ilk sayfadan veriyi okur.

http://s6.dosya.tc/server8/losb3k/dosya_adi_degistir3.zip.html

Kod:

Dim filepath2, filename2, deger, verihucre, kontrolhucre As String
Dim buldu As Boolean
Dim satir As Long
'www.asriakdeniz.com  asriakdeniz@gmail.com

Sub menu()
    satir = 1
    verihucre = Cells(2, 1).Value
    kontrolhucre = Cells(5, 1).Value
    Sheets("Log Sayfası").Range("A2:J64000").ClearContents
    Range("A2").Select
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Excel dosyalarının bulunduğu klasörü seçiniz."
        .Show
        If .SelectedItems.Count <> 0 Then
           Process_XLS_Files .SelectedItems(1)
        End If
    End With
    MsgBox ("Dosya adı değiştirme işlemi tamamlandı")
End Sub

Private Sub Process_XLS_Files(folderPath As String)
    Dim Folder As Scripting.Folder, Subfolder As Scripting.Folder, file As Scripting.file
    Dim wb As Workbook
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = Fso.GetFolder(folderPath)
    
    If Folder.subfolders.Count > 0 Then
      For Each Subfolder In Folder.subfolders
        For Each file In Subfolder.Files
          filepath2 = file.Path
          filename2 = file.Name
          Call isim_degistir
        Next
      Next
     Else
        For Each file In Folder.Files
          filepath2 = file.Path
          filename2 = file.Name
          Call isim_degistir
        Next
     End If
End Sub

Sub isim_degistir()
    Set sh = Sheets("Log Sayfası")
    dosyaadi = "[" & filename2 & "]"
    dosyayol = Mid(filepath2, 1, InStrRev(filepath2, "\"))
    uzanti = Mid(filename2, InStrRev(filename2, "."))
    sadeceadi = Mid(filename2, 1, InStrRev(filename2, ".") - 1)
    If Mid(filename2, InStrRev(filename2, ".")) Like ".xls*" Then
       buldu = False
       deger = verioku(filepath2, verihucre)
       If deger = "0" Or deger = "" Then
          satir = satir + 1
          sh.Cells(satir, 1).Value = filepath2
          sh.Cells(satir, 1).Hyperlinks.Add Anchor:=sh.Cells(satir, 1), Address:=filepath2
          If deger = "0" Then deger = ""
          sh.Cells(satir, 2).Value = deger
          sh.Cells(satir, 3).Value = verihucre & " Hücresinde değer bulunamadı."
          Exit Sub
       End If
       
       If hatalidosyaadi(deger) Then
          satir = satir + 1
          sh.Cells(satir, 1).Value = filepath2
          sh.Cells(satir, 1).Hyperlinks.Add Anchor:=sh.Cells(satir, 1), Address:=filepath2
          sh.Cells(satir, 2).Value = deger
          sh.Cells(satir, 3).Value = verihucre & "  Hücresinde dosya adında uygunsuz karakterler mevcut."
          Exit Sub
       End If
       
        For i = 1 To 1000
            yenidosyaadia = dosyayol & deger & "_" & i & "A" & uzanti
            yenidosyaadib = dosyayol & deger & "_" & i & "B" & uzanti
            
            If buldu Then
               If Not dosyavarmi(yenidosyaadib) And yenidosyaadib <> filepath2 Then
                  Name filepath2 As yenidosyaadib
                  Exit Sub
               End If
            Else
               If Not dosyavarmi(yenidosyaadia) And yenidosyaadia <> filepath2 Then
                  Name filepath2 As yenidosyaadia
                  Exit Sub
               End If
            End If
        Next i
          
   End If
End Sub

Function hatalidosyaadi(isim) As Boolean
    liste = Array("<", ">", "|", "/", "*", "\", "?", """")
    hatalidosyaadi = False
    For i1 = LBound(liste) To UBound(liste)
        If InStr(isim, liste(i1)) > 0 Then
           hatalidosyaadi = True
           Exit Function
        End If
    Next i1
End Function

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
     dosyavarmi = True
  Else
     dosyavarmi = False
  End If
End Function

Function verioku(dosya, hucresi) As String
   Dim Wkb As Workbook
   On Error GoTo hata
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   Set Wkb = Workbooks.Open(dosya, True, True)
   veri = Wkb.Worksheets(1).Range(hucresi).text
   On Error Resume Next
   bulunan = Wkb.Worksheets(1).Range(kontrolhucre).Find(What:=veri, LookAt:=xlWhole).text
   If veri = bulunan Then
      buldu = True
   End If
   
   Wkb.Close False
   Set Wkb = Nothing
   verioku = veri
hata:
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Function

RıdvanEroglu · 24 Şubat 2017

asri bey, makro da b26 hücresideki mükerrer isimler için 1234.xls, 1234(1).xls, 1234_1.xls gibi dosya isimleri vermesini sağlaybilirmisiniz?

RıdvanEroglu · 24 Şubat 2017

sayın dede vermiş olduğunuz makro yu bende denedim ve ASLAN7410 nın almış olduğu hatayı aldım.

dEdE · 24 Şubat 2017

Merhaba,
2 no.lu mesajdaki kod hatasını düzelttim. Yeniden dener misiniz?

RıdvanEroglu · 24 Şubat 2017

Sayın dede çok teşekkür ederim. Sorunsuz çalıştı. Kodun işlevsellik kazanması adına istirhamım b26 da boş değer ile karşılaştığında bir sonraki excele bakması. Mükerrer isimlerde (1), _1 ve benzeri değer vererek isimlendirme yapılması. Eminim bunlarda eklenildiğinde arşiv niteliğinde bir makro olmuş olacak.

Asri · 24 Şubat 2017

İlk mesajımdaki kod güncellendi. Dosya linki eklendi.

* Dosya adı var ise _1 ekleyerek arttırır.
* Dosya adı uygunsuz karakter içeriyor ise işlem yapmaz
* Tüm hatalı işlemler log sayfasında listelenir.

RıdvanEroglu · 24 Şubat 2017

asri ;

deger = Application.ExecuteExcel4Macro("'" & dosyayol & dosyaadi & "Sayfa1'!R26C2")

sayfa isimlerimin Safya-1 şeklinde olduğunu fark edip ilgili alanı düzeltip çalıştırmayı denediğimde bu sefer de

uzanti = Mid(filename2, InStrRev(filename2, "."))

satırında hata kodu aldım.

dosya isimlerini düzeltmek istediğim excel uzantılarının .xls olması sorun yaratmış olabilirmi ?

Asri · 24 Şubat 2017

RıdvanEroglu' Alıntı:
asri ;

deger = Application.ExecuteExcel4Macro("'" & dosyayol & dosyaadi & "Sayfa1'!R26C2")

sayfa isimlerimin Safya-1 şeklinde olduğunu fark edip ilgili alanı düzeltip çalıştırmayı denediğimde bu sefer de

uzanti = Mid(filename2, InStrRev(filename2, "."))

satırında hata kodu aldım.

dosya isimlerini düzeltmek istediğim excel uzantılarının .xls olması sorun yaratmış olabilirmi ?

Örnek dosyalarıı yükleyip link verebilir misiniz?

RıdvanEroglu · 24 Şubat 2017

Örnek dosya linki :

http://s6.dosya.tc/server8/sn89vo/Yeni_klasor.rar.html

Asri · 24 Şubat 2017

RıdvanEroglu' Alıntı:
Örnek dosya linki :

http://s6.dosya.tc/server8/sn89vo/Yeni_klasor.rar.html

Kodlar ve link güncellendi. Kapalı dosyada sayfa kontrolü eklendi.
Sayfa1 olarak sayfa yok ise log sayfasına yazacak, diğer işlemlere devam edecek.

ASLAN7410 · 24 Şubat 2017

Sayın dEdE ilginiz için çok teşekkür ediyorum, kodlar gayet güzel çalışıyor.
Ancak küçük bir sorun var, belirtmiş olduğum hücrede aynı numaralı dosyalar olabiliyor, bu şekilde olduğu zaman debug hatası veriyor, işlemi yapmıyor.

Sayın asri sizin de ilginize ayrıca teşekkür ederim, sizin kodlarda gayet güzel çalışıyor, her türlü excel sayfasındaki belirtmiş olduğum hücredeki bilgileri dosya ismi olarak yazıyor, Rıdvan arkadaşımızın göndermiş olduğu örnekte kodları denedim, arkadaşın göndermiş olduğu dosyadaki hücrede sayılar metin olarak yazılı olduğu için bu hücreyi almıyor.

Belirtmiş olduğum hücredeki değer nasıl bir değer olursa olsun, bu değeri dosya ismi olarak yazmasını istiyorum, ayrıca mükerrer kayıtlarda da 123456_1 veya 123456(1) şeklinde olursa çok güzel olacak.

Yardımcı olur musunuz?

Asri · 24 Şubat 2017

ASLAN7410' Alıntı:
...Sayın asri sizin de ilginize ayrıca teşekkür ederim, sizin kodlarda gayet güzel çalışıyor, her türlü excel sayfasındaki belirtmiş olduğum hücredeki bilgileri dosya ismi olarak yazıyor, Rıdvan arkadaşımızın göndermiş olduğu örnekte kodları denedim, arkadaşın göndermiş olduğu dosyadaki hücrede sayılar metin olarak yazılı olduğu için bu hücreyi almıyor.

Belirtmiş olduğum hücredeki değer nasıl bir değer olursa olsun, bu değeri dosya ismi olarak yazmasını istiyorum, ayrıca mükerrer kayıtlarda da 123456_1 veya 123456(1) şeklinde olursa çok güzel olacak.

Yardımcı olur musunuz?

Sayın Rıdvan ın gönderdiği dosyada metin içerikten dolayı değil. Bilginin alınacağı sayfanın adının Sayfa1 yerine Sayfa-1 olmasından kaynaklanıyor.

Programın log sayfasına bakarsanız bu sorun ile ilgili bilgiyi görebilirsiniz.

Ayrıca program aynı isimde dosya var ise _1 , _2 olarak adlandırma yapıyor.

Son göndermiş olduğun dosya yada kodları denediniz mi?

ASLAN7410 · 24 Şubat 2017

Sayın asri , problemin sayfa isminden kaynaklandığını yazmışsınız, sayfa isimleri değişik isimlerde de olabiliyor.

Asri · 24 Şubat 2017

ASLAN7410' Alıntı:
Sayın asri , programın log sayfası dediğiniz yeri bulamadım, neresi tarif edebilir misiniz?

Ayrıca sayfa isminden kaynaklandığını yazmışsınız, sayfa isimleri değişik isimlerde de olabiliyor.

İlk mesajımdaki dosya linkinden dosyayı indirip kontrol ediniz.

ASLAN7410 · 24 Şubat 2017

Sayın asri dediğiniz dosyayı indirdim, kodlar gayet güzel çalıyor, ellerinize sağlık.

Dosyalardaki sayfa isimleri Sayfa1 olmayan sayfaları log sayfasına yazıyor, çoğu sayfaların adları farklı farklı olduğu için çok uğraştıracak, sayfa isimleri ne olursa olsun, yinede dosyanın ismini değiştirebilir mi?

ASLAN7410 · 24 Şubat 2017

Sayın asri kodlar arasındaki Sayfa1 yazılı yerleri Sheets(1) olarak değiştirdim, debug hatası verdi, aşağıdaki kodu sarıya boyadı.

Kod:

GV = ExecuteExcel4Macro("'" & ParentFolder & "\[" & FileName & "]" & ShtName & "'!R1C1")

Dosya adlarını hücreden alma

ASLAN7410

Ekli dosyalar

dEdE

Destek Ekibi

ASLAN7410

dEdE

Destek Ekibi

Asri

RıdvanEroglu

RıdvanEroglu

dEdE

Destek Ekibi

RıdvanEroglu

Asri

RıdvanEroglu

Asri

RıdvanEroglu

Asri

ASLAN7410

Asri

ASLAN7410

Asri

ASLAN7410

ASLAN7410