• DİKKAT

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

Dosya adlarını hücreden alma

ASLAN7410' Alıntı:
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")
Genişletmek için tıkla ...

Kapalı dosya üzerinden işlem yapıldığı için bu şekilde olmaz.
Doğru kodu bulmak lazım. Sorunu çözünce bilgi veririm.
 
Yardımcı olursanız çok sevinirim, bu kodlara gerçekten çok ihtiyacım var, dosyalarım çok olduğu için çok uğraştırıyor.
 
Sayın asri, imzanızın alt kısmında bulunan www.asriakdeniz.com sitenizdeki örnekler çok güzel çokta işime yaradı, dosya adlarını hücreden alma konu ile ilgili olarak sadece B26 hücresine bağlı kalmadan, getirmek istediğimi hücrenin ismini sitenizdeki örnekler gibi kodların bulunmuş olduğu sayfanın bir hücresine yazsak bu şekilde getirirse daha iyi olacak ve bu programda başka dosyalar içinde kullanılabilir.
 
Merhaba,

Bende bir şeyler karaladım. Tam istediğiniz sonucu vermeyebilir. Bu sebeple verilerinizi yedekleyerek deneyiniz.

Kod: 
Option Explicit

Sub DOSYA_İSİMLERİNİ_DEĞİŞTİR()
    Dim Uygulama As Object, Klasör As Object, Dosya As String, Dosyalar As Object, Kitap As Object
    Dim Nesne As Object, Dosya_Adi As String, K1 As Workbook, Say As Integer, Kontrol As String, X As Integer
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör seçiniz !", 1)
    If Klasör Is Nothing Then Exit Sub
    
    Dosya = Dir(Klasör.Self.Path & "\*.xls*")
    
    Set Nesne = CreateObject("Scripting.FileSystemObject")
    Set Uygulama = CreateObject("Excel.Application")
    Uygulama.Visible = False
    
    While Dosya <> ""
        Set K1 = Uygulama.Workbooks.Open(Klasör.Self.Path & "\" & Dosya)
        DoEvents
        Dosya_Adi = K1.Sheets(1).Range("B26")
        Uygulama.Workbooks.Close
        Set Dosyalar = Nesne.GetFolder(Klasör.Self.Path & "\")
        For Each Kitap In Dosyalar.Files
            If InStr(1, Kitap.Name, Dosya_Adi) > 0 Then
                Say = Say + 1
            End If
        Next
        If Say > 0 Then
            On Error Resume Next
            Name Klasör.Self.Path & "\" & Dosya As Klasör.Self.Path & "\" & Dosya_Adi & "_" & Say & "." & Nesne.GetExtensionName(Dosya)
            For X = Say + 1 To 5000
                If Err.Number = 58 Then
                    Name Klasör.Self.Path & "\" & Dosya As Klasör.Self.Path & "\" & Dosya_Adi & "_" & X & "." & Nesne.GetExtensionName(Dosya)
                End If
            Next
        Else
            Name Klasör.Self.Path & "\" & Dosya As Klasör.Self.Path & "\" & Dosya_Adi & "." & Nesne.GetExtensionName(Dosya)
        End If
        Say = 0
        Dosya = Dir
    Wend
    
    Uygulama.Quit
        
    Set Klasör = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Sayın Korhan Bey ellerinize sağlık, çok teşekkür ediyorum, tam işimi gördü, hayırlı çalışmalar, hayırlı geceler diliyorum.

Diğer bu konu ile cevap veren dEdE ve asri'ye de ayrıca teşekkür ederim.
 
ASLAN7410' Alıntı:
Sayın Korhan Bey ellerinize sağlık, çok teşekkür ediyorum, tam işimi gördü, hayırlı çalışmalar, hayırlı geceler diliyorum.

Diğer bu konu ile cevap veren dEdE ve asri'ye de ayrıca teşekkür ederim.
Genişletmek için tıkla ...

İlk mesajımdaki dosya güncellendi. Sayfa adı önemli değil, ilk sayfadan veri okur.
 
RıdvanEroglu' Alıntı:
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.
Genişletmek için tıkla ...

Merhaba,
Sayın asri usta işi bir kod yazmış. Bunu kullanabilirsiniz. Benim yazdığım kod da istediğiniz düzeltmeleri yapmak mümkün ama ancak hafta başında bakabileceğim.
Gerekli ise düzenlemeyi yaparız. Hoşça kalın.
 
Sayın asri çok teşekkür ederim, çok güzel bir çalışma oldu, ellerinize sağlık hayırlı çalışmalar, hayırlı geceler diliyorum.

Sayın dEdE, asri ve Korhan Bey'in gönderdikleri işimi gördü, size de ayrıca teşekkür ederim.
Hayırlı çalışmalar hayırlı geceler diliyorum.
 
asri bey,
b26 değeri d sütununda 50.satıra a kadar benzer değer var ise isim sonuna _A yok ise _B gibi bir değer daha eklenebilir mi ?
 
RıdvanEroglu' Alıntı:
asri bey,
b26 değeri d sütununda 50.satıra a kadar benzer değer var ise isim sonuna _A yok ise _B gibi bir değer daha eklenebilir mi ?
Genişletmek için tıkla ...

Merhaba,

Benzer değer ne demek? aynı mı? Bir kaç sayısı farklı mı?

Son gönderdiğim dosyada örnekleyip link verebilir misiniz?

İsimin sonuna _A _B eklenirse mükerrer olabilir.
ancak, _1A _2B gibi eklenebilir.
 
RıdvanEroglu' Alıntı:
Evet aynısı.
Örnek de 1 ve 2 exceller b26 hücresinden isim alırken b26 d1-d50 stunları arasında tekrarlamadığı için sonlarına _A değerini alırken. Excel 3 ve 4 sonlarına _B değerini almalı.

http://s9.dosya.tc/server2/gbmxli/1.rar.html
Genişletmek için tıkla ...

"Örnek de 1 ve 2 exceller b26 hücresinden isim alırken b26 d1-d50 stunları arasında tekrarlamadığı için sonlarına _A"
Bu şekilde yapılır ise aynı şartı sağlayan başka bir dosyada da sonuna _A eklenir bu şekilde aynı isimden iki adet dosya oluşabilir.
Bu yüzden _1A _2A şeklinde isimlendirilmeli.
 
RıdvanEroglu' Alıntı:
_1A, _2A... olabilir.
Değerin tekrarı yok ise _1B, _2B... şeklinde isimlendirilebilir mi?
Genişletmek için tıkla ...

İlk mesajımdaki kod ve dosya güncellendi.

Hatalı dosyalara link eklendi. Excel içinden direkt açılabilecek.
İsimlendirme kritere göre yapıldı.
 
Merhabalar benimde elimde bir dosyam var hücre adına göre otomatik dosya adı veriyor.fakat mükerrer olan dosya isimlerini dosyanın sonuna 1-2-diye ekleme yaparak kaydetme nasıl yapabilirim.

Kod: 
' TANIMLAMALAR

Dim s1  As Worksheet, _
s2  As Worksheet, _
s3  As Worksheet, _
s4  As Worksheet

Set s1 = Sheets("yerli")
Set s2 = Sheets("gelen data")
Set s3 = Sheets("altformul")
Set s4 = Sheets("pdf")


yol = ThisWorkbook.Path 'dosyanın bulunduğu yola kaydeder
isim = s4.Range("C4").Value 'buradan dosya ismi atanabilir

' PDF OLARAK KAYDET

s4.Select ' a-t sütunları son dolu satıra kadar seçildi
s4.Range("A1:T" & sonsatirpdf).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & "/" & isim & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True

s4.Select
s4.Range("A1").Select

' XLSX OLARAK KAYDET

s2.Copy
ActiveWorkbook.SaveAs yol & "/" & isim & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True

'Pdf butonuna tıkladıktan sonra otomatik gelen data sayfası çıktısı alınır.

s2.PrintOut

' BİTTİ

Application.ScreenUpdating = True

End Sub
 
yeni konu açmak istemedim bilgi kirliliği olmaması adına yardımcı olabilicek kimse yokmudur?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst