Hücre Adı Dosya Adına Eşitse Dosyaya Kayıt Yap.!!!!!

[sinan05]

İyi Günler Değerli Sayın Hocalarım. Bir hususta, yardımınıza ihtiyacım var lütfen. Çalışma kitabımdan belirli klasördeki dosyalara yeni sayfa oluşturup kayıt yaptığım çalışmam var. kodlarında bir işlemi dolaylı yoldan yapıyorum. Bu işlemi kısaltmam lazım. Aşağıya eklediğim kodlarla, şu koşula göre kayıt yapıyorum; eğer ARAÇ KAYITLARI klasöründeki dosyaların Sayfa1 sayfasının a1 hücresi çalışma kitabımdaki araç kayıtları sayfası s1 hücresine eşitse o dosyanın içine yeni sayfa oluşturup kodlarda devam eden işlemleri yapıyorum. Yani burda belirli klasördeki hangi dosyanın içine kayıt yapması gerektiğini belirtiyorum. Benim istediğim kayıt yapacağı dosyayı bulması için dosyanın içindeki sayfa1 sayfasına bakmaktansa, klasördeki dosyaların hangisinin ismi çalışma kitabımdaki araç kayıtları sayfasının s1 hücresine eşitse o dasyanın içine kayıt yapsın. Çok şey denedim ama doğru ifadeyi bulamadım.Değiştirmek istediğim kod bu;
If Dosyam.Sheets("Sayfa1").Range("a1") = kitap.Sheets("ARAÇ KAYIT").Range("s1") Then

Sub Kaydet()
Application.ScreenUpdating = False
Set S1 = Sheets("ARAÇ KAYIT")
Set S2 = Sheets("ÖRNEK TASLAK")
Set s3 = Sheets("ARAÇ LİSTESİ")
Dim evn As Object, klasoradi As String, kitap As Workbook
Dim i As Integer, Dosyam As Workbook
Set kitap = ThisWorkbook
ad = S1.Cells(1, "S").Value
ad1 = S1.Cells(4, "B") & "_" & S1.Cells(5, "B").Value
ad2 = S1.Cells(4, "B") & "_" & S1.Cells(5, "B").Value & "_" & S1.Cells(2, "V").Value
klasoradi = "ARAÇ KAYITLARI"
Set evn = CreateObject("scripting.filesystemobject")
Set dosyalar = evn.getfolder(ThisWorkbook.Path & Application.PathSeparator & klasoradi)
For Each klasor In dosyalar.Files
Set Dosyam = Application.Workbooks.Open(klasor.Path)
Set Dosyami = GetObject(klasor.Path)
For i = 1 To Dosyam.Sheets.Count
If Dosyam.Sheets("Sayfa1").Range("a1") = kitap.Sheets("ARAÇ KAYIT").Range("s1") Then
S2.Cells.Copy
With Dosyam.Sheets
Dosyam.Sheets.Add After:=Dosyam.Sheets(Dosyam.Sheets.Count)
Dosyam.Sheets(Dosyam.Sheets.Count).Name = ad1
Dosyam.Sheets(Dosyam.Sheets.Count).Paste
Dosyam.Sheets(Dosyam.Sheets.Count).Range("a1").Select
Application.CutCopyMode = False
x = s3.Cells(Rows.Count, "A").End(3).Row + 1
s3.Cells(x, "A") = S1.[B2]
s3.Cells(x, "B") = S1.[B3]
s3.Cells(x, "C") = S1.[B4]
s3.Cells(x, "D") = S1.[B5]
s3.Hyperlinks.Add Anchor:=s3.Cells(x, "B"), Address:= _
"ARAÇ KAYITLARI\" & ad & ".xlsx", SubAddress:="'" & ad1 & "'!A1", TextToDisplay:=S1.Cells(3, "B").Value
With s3.Cells(x, "B").Font
.Size = 16
.Underline = xlUnderlineStyleNone
End With
Dosyam.Close True
S2.Visible = False
End With
Exit Sub
End If
Next i
Dosyam.Close True
Next klasor
Set evn = Nothing: Set kitap = Nothing: Set Dosyam = Nothing
Application.ScreenUpdating = True
End Sub

 

[Korhan Ayhan]

Merhaba,

Siz sorgunuzu "i" döngüsü altına yazmışsınız. Bu durumda o sorgu satırını ve ilgili End If satırını komple silmelisiniz.

Bu satırın For Each klasor In dosyalar.Files hemen altına aşağıdaki koşulu yazınız.

If klasor.Name = kitap.Sheets("ARAÇ KAYIT").Range("s1") Then


Bu satırın Next klasor hemen üstüne ise End If komutunu ekleyiniz.

Burada önemli olan S1 hücresinde dosya adının nasıl yazdığıdır. Eğer dosya uzantısı yoksa eklemeniz gerekecektir.

 

[sinan05]

Merhaba,

Siz sorgunuzu "i" döngüsü altına yazmışsınız. Bu durumda o sorgu satırını ve ilgili End If satırını komple silmelisiniz.

Bu satırın For Each klasor In dosyalar.Files hemen altına aşağıdaki koşulu yazınız.

If klasor.Name = kitap.Sheets("ARAÇ KAYIT").Range("s1") Then


Bu satırın Next klasor hemen üstüne ise End If komutunu ekleyiniz.

Burada önemli olan S1 hücresinde dosya adının nasıl yazdığıdır. Eğer dosya uzantısı yoksa eklemeniz gerekecektir.

Sayın Korhan Hocam teşekkür ederim öncelikle ben amatörüm pek anlamıyorum fakat benim durum biraz karışık. O sorgudan önce yine kayıt yapan benzer kodlar var. o kodlarıda aynı sayfa ismine ait 2. bir kayıt yapılırsa, bu 2. kayıtın sayfa ismine saat ve dakkadan oluşan rakam ekleyerek kaydı tamamlıyor. i döngüsünü koymazsam eğer dosyadaki sayfaların hepsini dolaşmıyor bu yüzden aynı isme ait bir kayıt varmı göremiyor sadece son sayfayı baz alıyor, bu sefer aynı isme sahip 2. bir kayıt yapmaya çalışırken hata veriyor. Tabi siz daha iyi bilirsiniz makronun tamamını aşağıya ekliyorum Hocam.

Sub Kaydet()
Application.ScreenUpdating = False
Set S1 = Sheets("ARAÇ KAYIT")
Set S2 = Sheets("ÖRNEK TASLAK")
Set s3 = Sheets("ARAÇ LİSTESİ")
s3.Unprotect
S2.Visible = True
S1.Range("b2:B4").Copy
S2.Range("a2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
S1.Range("b5:B8").Copy
S2.Range("a4").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
Dim evn As Object, klasoradi As String, kitap As Workbook
Dim i As Integer, Dosyam As Workbook
Set kitap = ThisWorkbook
ad = S1.Cells(1, "S").Value
ad1 = S1.Cells(4, "B") & "_" & S1.Cells(5, "B").Value
ad2 = S1.Cells(4, "B") & "_" & S1.Cells(5, "B").Value & "_" & S1.Cells(2, "V").Value
klasoradi = "ARAÇ KAYITLARI"
Set evn = CreateObject("scripting.filesystemobject")
Set dosyalar = evn.getfolder(ThisWorkbook.Path & Application.PathSeparator & klasoradi)
For Each klasor In dosyalar.Files
Set Dosyam = Application.Workbooks.Open(klasor.Path)
Set Dosyami = GetObject(klasor.Path)
    For i = 1 To Dosyam.Sheets.Count
    For y = 1 To Dosyami.Sheets.Count
        If Dosyam.Sheets("Sayfa1").Range("a1") = kitap.Sheets("ARAÇ KAYIT").Range("s1") Then
           If Dosyami.Sheets(y).Cells(2, "c") & "_" & Cells(2, "d").Value = ad1 Then
                Dim cevap As Integer
                cevap = MsgBox("Klasörün İçindeki Dosyalarda Aynı Plaka ve Tarihe Sahip Başka Bir Araç Kaydı Bulunmuştur.Kayda devam ederseniz, yeni oluşturulcak aracın plakasının sonuna Tarih eklenecektir.Eğer kayda devam etmek istiyorsanız, Evet'İ Seçin ", vbYesNo + vbQuestion, "ONAY")
             If cevap = vbNo Then
                MsgBox "Yeni Araç Kaydı İptal Edilmiştir."
                Dosyam.Close True
                S2.Visible = False
                Exit Sub
                Else
                S2.Cells(2, "B") = S1.Cells(3, "B") & "_" & S1.Cells(3, "S")
                S2.Cells.Copy
                With Dosyam.Sheets
                Dosyam.Sheets.Add After:=Dosyam.Sheets(Dosyam.Sheets.Count)
                Dosyam.Sheets(Dosyam.Sheets.Count).Name = ad2
                Dosyam.Sheets(Dosyam.Sheets.Count).Paste
                Dosyam.Sheets(Dosyam.Sheets.Count).Range("a1").Select
                 Application.CutCopyMode = False
                 x = s3.Cells(Rows.Count, "A").End(3).Row + 1
                 s3.Cells(x, "A") = S1.[B2]
                 s3.Cells(x, "B") = S1.[B3]
                 s3.Cells(x, "C") = S1.[B4]
                 s3.Cells(x, "D") = S1.[B5]
                 s3.Hyperlinks.Add Anchor:=s3.Cells(x, "B"), Address:= _
                 "ARAÇ KAYITLARI\" & ad & ".xlsx", SubAddress:="'" & ad2 & "'!A1", TextToDisplay:=S1.Cells(3, "B") & "_" & S1.Cells(3, "S").Value
                 With s3.Cells(x, "B").Font
                  .Size = 16
                  .Underline = xlUnderlineStyleNone
                 End With
                 Dosyam.Close True
                 S2.Visible = False
                 s3.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                 End With
                Exit Sub
               End If
              End If
            End If
          Next y
          If Dosyam.Sheets("Sayfa1").Range("a1") = kitap.Sheets("ARAÇ KAYIT").Range("s1") Then
                S2.Cells.Copy
                With Dosyam.Sheets
                Dosyam.Sheets.Add After:=Dosyam.Sheets(Dosyam.Sheets.Count)
                Dosyam.Sheets(Dosyam.Sheets.Count).Name = ad1
                Dosyam.Sheets(Dosyam.Sheets.Count).Paste
                Dosyam.Sheets(Dosyam.Sheets.Count).Range("a1").Select
                 Application.CutCopyMode = False
                 x = s3.Cells(Rows.Count, "A").End(3).Row + 1
                 s3.Cells(x, "A") = S1.[B2]
                 s3.Cells(x, "B") = S1.[B3]
                 s3.Cells(x, "C") = S1.[B4]
                 s3.Cells(x, "D") = S1.[B5]
                 s3.Hyperlinks.Add Anchor:=s3.Cells(x, "B"), Address:= _
                 "ARAÇ KAYITLARI\" & ad & ".xlsx", SubAddress:="'" & ad1 & "'!A1", TextToDisplay:=S1.Cells(3, "B").Value
                  With s3.Cells(x, "B").Font
                  .Size = 16
                  .Underline = xlUnderlineStyleNone
                 End With
                 Dosyam.Close True
                 S2.Visible = False
                 s3.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
                 End With
               Exit Sub
            End If
         Next i
     Dosyam.Close True
  Next klasor
Set evn = Nothing: Set kitap = Nothing: Set Dosyam = Nothing
Application.ScreenUpdating = True
End Sub

Ayrıca hocam aşağıdaki kodlarla ilk kaydı yapan kodlarla değiştirerek çözüm buldum fakat aynı isimden dosya varsa 2. kaydı yapan kodlara uyarlayamadım.

If evn.FileExists(ThisWorkbook.Path & "\ARAÇ KAYITLARI\" & ad & ".xlsx") = True Then
                Workbooks.Open ThisWorkbook.Path & "\ARAÇ KAYITLARI\" & ad & ".xlsx"
                S2.Cells.Copy
                With ActiveWorkbook
                Sheets.Add After:=.Sheets(.Sheets.Count)
                .Sheets(Sheets.Count).Name = ad1
                .Sheets(.Sheets.Count).Paste
                .Sheets(.Sheets.Count).Range("a1").Select
                Application.CutCopyMode = False

 

[Korhan Ayhan]

Ben sizin tarifinize göre yanıt vermiştim. Sonradan sorular değişince işler can sıkıcı olmaya başlıyor. Sonuçta bizler sizlerin gerçek dosyalarınızda neler yapmaya çalıştığınızı bilemeyiz. Bu sebeple yönlendirmeleriniz bizim için çok önemlidir.

"i" döngüsündeki sorgu satırını başka bir işlem için kullanıyorsanız silin dediğim işlemi yapmayınız.

Sadece benim verdiğim ek koşulu ilgili yere ekleyip kullanabilirsiniz.

 

[sinan05]

Ben sizin tarifinize göre yanıt vermiştim. Sonradan sorular değişince işler can sıkıcı olmaya başlıyor. Sonuçta bizler sizlerin gerçek dosyalarınızda neler yapmaya çalıştığınızı bilemeyiz. Bu sebeple yönlendirmeleriniz bizim için çok önemlidir.

"i" döngüsündeki sorgu satırını başka bir işlem için kullanıyorsanız silin dediğim işlemi yapmayınız.

Sadece benim verdiğim ek koşulu ilgili yere ekleyip kullanabilirsiniz.

Hocam haklısınız bense gereksiz olur ve uzun diye makronun tamamını koymadım.dediğinizi deneyeceğim hocam ama biraz vaktimi alacak. Acaba mümkünse benim kodları doğrumu sıralamışım, en verimli dizilimi nasıl olur bakabilirmisiniz. Aynı 2. Kayıt kodlarını alttaki kodlarla birleştiremezmiyiz.

 

[sinan05]

Ben sizin tarifinize göre yanıt vermiştim. Sonradan sorular değişince işler can sıkıcı olmaya başlıyor. Sonuçta bizler sizlerin gerçek dosyalarınızda neler yapmaya çalıştığınızı bilemeyiz. Bu sebeple yönlendirmeleriniz bizim için çok önemlidir.

"i" döngüsündeki sorgu satırını başka bir işlem için kullanıyorsanız silin dediğim işlemi yapmayınız.

Sadece benim verdiğim ek koşulu ilgili yere ekleyip kullanabilirsiniz.

Korhan Hocam sizin verdiğiniz kodla daha iyi oldu. Sizin kodun altına yazdığım kodlar dosyaların hepsini açıyor sadece eşit olan dosyayı açmak için nasıl bir kod yazmalıyım. Lütfen yardımcı olursanız sevinirim.