• DİKKAT

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

Kapalı excel dosyalarına kriter gözeterek veri aktarmak.

  • Konbuyu başlatan Konbuyu başlatan Bora K
  • Başlangıç tarihi Başlangıç tarihi
B

Bora K

Katılım
21 Ocak 2013
Mesajlar
331
Excel Vers. ve Dili
2003 Türkçe
Sitemize değer katan;
Sayın Korhan Ayhan, Sayın Halit3, Sayın Orion1, Sayın Hamitcan ve
ismini yazamadığım diğer uzmanlar beni affetsin.

Lütfen konuya müdahil olunuz. Ekteki dosyam için;

http://www.excel.web.tr/f48/kapaly-dosyalara-veri-aktarma-makrosu-duzeltme-talebi-t124811.html
Bu başlıkta Sayın Dentex in yardımını aldım. Kod benim dosyalarda sorun çıkarttığı için kodu kullanamıyorum.
Kod sorunsuz. Eminim birçok arkadaşımızın ihtiyacını görecektir. Kendisine bir kez daha teşekkür ederim.

http://www.excel.web.tr/f48/veri-aktarma-t124650.html
Bu başlıkta Sayın Asi Kral ın yardımını aldım. Benim dosyalar yaklaşık 10 mb. Kod yeniden kayıt mantığı
ile çalışıyor sanırım. Dolayısı ile çok ağır. Maalesef bu koduda kullanamıyorum.

Saygılarımla.
 

Ekli dosyalar

Lütfen Sayın Uzmanlarımız
Belkide sizin 10 dk zamanınızı alacak.
2 aydır bu dosyayı bitiremedim

Yardım bekliyorum.
 
Kapalı excel dosyalarını açacak.
İstediğim verileri yazıp tekrar kapatacak
bir makro istemekteyim.
 
Hiçde 10 dakikada hazırlanacak koda benzemiyor baya uğraştırdı

Sorunuzu sorarken isim zikretmeyiniz.

kod:

Kod: 
Sub verikayityap()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
Dim wb As Workbook
On Error Resume Next
For Each Dosya In fs
If ThisWorkbook.Name <> Dosya.Name Then
Set wb = Workbooks.Open(Dosya)
For i = 7 To ThisWorkbook.Worksheets("liste").Cells(Rows.Count, "D").End(3).Row
aranan1 = ThisWorkbook.Worksheets("liste").Cells(i, "D").Value
aranan2 = ThisWorkbook.Worksheets("liste").Cells(i, "f").Value
aranan3 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value
aranan4 = ThisWorkbook.Worksheets("liste").Cells(i, "ı").Value
aranan5 = ThisWorkbook.Worksheets("liste").Cells(i, "k").Value
aranan6 = ThisWorkbook.Worksheets("liste").Cells(i, "l").Value
aranan7 = ThisWorkbook.Worksheets("liste").Cells(i, "m").Value
If aranan7 <> "Ok" Then
For j = 7 To Sheets("Data").Cells(Rows.Count, "D").End(3).Row
bulunan1 = Sheets("Data").Cells(j, "D").Value
bulunan2 = Sheets("Data").Cells(j, "f").Value
bulunan3 = Sheets("Data").Cells(j, "h").Value
If aranan1 = bulunan1 Then
If aranan2 = bulunan2 Then
If bulunan3 = "" Then
Sheets("Data").Cells(j, "h").Value = aranan3
Sheets("Data").Cells(j, "ı").Value = aranan4
Sheets("Data").Cells(j, "k").Value = aranan5
Sheets("Data").Cells(j, "l").Value = aranan6
ThisWorkbook.Worksheets("liste").Cells(i, "m").Value = "Ok"
Exit For
End If
End If
End If
Next j
End If
Next i
ActiveWorkbook.Save
ActiveWindow.Close
End If
Dir Dosya
Next
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
 
Merhaba Halit Bey.

Çok özür dilerim. Yaptığım davarınş etik değildi.
Lakin uzun süredir dosyayı sonlandıramadığım için son çare
olarak siz uzmanlarımızdan yardım almak istedim. Ki bu tür kodu
yazacak insanda forumda sayılıdır. Elleriniz dert görmesin.
Allah ne muradınız var ise nasip etsin inşallah.

Halit Bey makro çalıştıktan sonra sadece aktarılan verileri
M sütununda "ok" ile işaretleyecektik. Bu gözden kaçtı sanırım.

"ok" yazısı ile hem aktarılan verileri görmüş olacağız.
Hemde aynı klasör için makroyu ikinci kez çalıştırdığmızda :
İlk çalıştırdığımzda gönderdiğimiz verileri tekrar göndermemiş olacağız.
(Eğer M sütununda "ok" yazıyor ise; "ok" yazan satırdaki veriler hiçbir surette
aktarılmayacak)
Bu ilaveyi yapabilirseniz çok sevinirim.
Teşekkür ederim
 
Son düzenleme:
Bora K' Alıntı:
Merhaba Halit Bey.

Çok özür dilerim. Yaptığım davarınş etik değildi.
Lakin uzun süredir dosyayı sonlandıramadığım için son çare
olarak siz uzmanlarımızdan yardım almak istedim. Ki bu tür kodu
yazacak insanda forumda sayılıdır. Elleriniz dert görmesin.
Allah ne muradınız var ise nasip etsin inşallah.

Halit Bey makro çalıştıktan sonra sadece aktarılan verileri
M sütununda "ok" ile işaretleyecektik. Bu gözden kaçtı sanırım.

"ok" yazısı ile hem aktarılan verileri görmüş olacağız.
Hemde aynı klasör için makroyu ikinci kez çalıştırdığmızda :
İlk çalıştırdığımzda gönderdiğimiz verileri tekrar göndermemiş olacağız.
(Eğer M sütununda "ok" yazıyor ise; "ok" yazan satırdaki veriler hiçbir surette
aktarılmayacak)
Bu ilaveyi yapabilirseniz çok sevinirim.
Teşekkür ederim
Genişletmek için tıkla ...

4 nolu mesajdaki kodu düzelttim.
 
For i = 7 To ThisWorkbook.Worksheets("liste").Cells(Rows.Count, "D").End(3).Row
aranan1 = ThisWorkbook.Worksheets("liste").Cells(i, "D").Value
aranan2 = ThisWorkbook.Worksheets("liste").Cells(i, "f").Value
aranan3 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value
aranan4 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value
aranan5 = ThisWorkbook.Worksheets("liste").Cells(i, "ı").Value
aranan6 = ThisWorkbook.Worksheets("liste").Cells(i, "k").Value
aranan7 = ThisWorkbook.Worksheets("liste").Cells(i, "l").Value
aranan8 = ThisWorkbook.Worksheets("liste").Cells(i, "m").Value
If aranan8 <> "Ok" Then

Merhaba Halit Bey.
Sizi tekrardan rahatsız ediyorum.
Özür dilerim.

** Bir önceki mesajımda belirtmiş idim. M sütununda "ok" yazıyor ise
"ok" yazan satırdaki veriler hiçbir surutte aktarılmasın istiyorum.

** Dosya seçmek amacı ile makroyu çalıştırdığımızda an itibari ile "masaüstünü" açıyor.
Masaüstü nü değilde Sürücü "D" yi açar ise bana zaman kazandıracak.

Bunların yanında birde malumat istiyorum sayın üstad.
Kodu incelediğimde; Makronun yukarıdaki kesitinde kalın yazı ile belirttiğim kısımda
"h" sütununun 2 tane olduğunu gördüm.
Neden "h" 2 tane bunu öğrenmek istiyorum bilgilenmek amacı ile.

Makroyu başka dosyalarda da kullanacağım. Ve o dosyalarda sütun adresleri
farklı. Herhangi bir hataya mahal bırakmamak amacındayım.

Saygılarımla.
 
Bora K' Alıntı:
For i = 7 To ThisWorkbook.Worksheets("liste").Cells(Rows.Count, "D").End(3).Row
aranan1 = ThisWorkbook.Worksheets("liste").Cells(i, "D").Value
aranan2 = ThisWorkbook.Worksheets("liste").Cells(i, "f").Value
aranan3 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value
aranan4 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value
aranan5 = ThisWorkbook.Worksheets("liste").Cells(i, "ı").Value
aranan6 = ThisWorkbook.Worksheets("liste").Cells(i, "k").Value
aranan7 = ThisWorkbook.Worksheets("liste").Cells(i, "l").Value
aranan8 = ThisWorkbook.Worksheets("liste").Cells(i, "m").Value
If aranan8 <> "Ok" Then

Merhaba Halit Bey.
Sizi tekrardan rahatsız ediyorum.
Özür dilerim.

** Bir önceki mesajımda belirtmiş idim. M sütununda "ok" yazıyor ise
"ok" yazan satırdaki veriler hiçbir surutte aktarılmasın istiyorum.

** Dosya seçmek amacı ile makroyu çalıştırdığımızda an itibari ile "masaüstünü" açıyor.
Masaüstü nü değilde Sürücü "D" yi açar ise bana zaman kazandıracak.

Bunların yanında birde malumat istiyorum sayın üstad.
Kodu incelediğimde; Makronun yukarıdaki kesitinde kalın yazı ile belirttiğim kısımda
"h" sütununun 2 tane olduğunu gördüm.
Neden "h" 2 tane bunu öğrenmek istiyorum bilgilenmek amacı ile.

Makroyu başka dosyalarda da kullanacağım. Ve o dosyalarda sütun adresleri
farklı. Herhangi bir hataya mahal bırakmamak amacındayım.

Saygılarımla.
Genişletmek için tıkla ...

Kodun bu bölümü fazla
Kod: 
aranan3 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value

Ok işaretinide bu bölümde veri sayfasına koyuyor

Kod: 
ThisWorkbook.Worksheets("liste").Cells(i, "m").Value = "Ok"
 
Kodda daha önce kontrol vardı şimdi ok işareti istemiştiniz kodu teniden değiştirdim.

kod

Kod: 
Sub verikayityap()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
Dim wb As Workbook
On Error Resume Next
For Each dosya In fs
If ThisWorkbook.Name <> dosya.Name Then
Set wb = Workbooks.Open(dosya)
For i = 7 To ThisWorkbook.Worksheets("liste").Cells(Rows.Count, "D").End(3).Row
aranan1 = ThisWorkbook.Worksheets("liste").Cells(i, "D").Value
aranan2 = ThisWorkbook.Worksheets("liste").Cells(i, "f").Value
aranan3 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value
aranan4 = ThisWorkbook.Worksheets("liste").Cells(i, "ı").Value
aranan5 = ThisWorkbook.Worksheets("liste").Cells(i, "k").Value
aranan6 = ThisWorkbook.Worksheets("liste").Cells(i, "l").Value
For j = 7 To Sheets("Data").Cells(Rows.Count, "D").End(3).Row
bulunan1 = Sheets("Data").Cells(j, "D").Value
bulunan2 = Sheets("Data").Cells(j, "f").Value
bulunan3 = Sheets("Data").Cells(j, "m").Value
If bulunan3 <> "Ok" Then
If aranan1 = bulunan1 Then
If aranan2 = bulunan2 Then
Sheets("Data").Cells(j, "h").Value = aranan3
Sheets("Data").Cells(j, "ı").Value = aranan4
Sheets("Data").Cells(j, "k").Value = aranan5
Sheets("Data").Cells(j, "l").Value = aranan6
Sheets("Data").Cells(j, "m").Value = "Ok"
Exit For
End If
End If
End If
Next j
Next i
ActiveWorkbook.Save
ActiveWindow.Close
End If
Dir dosya
Next
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
 
Üstad kendimi aptal gibi hissediyorum.
"ok" ile ilgili sorun yokmuş. Ben "Ok" yazısını "ok" ile değiştirmiştim.
"Ok" 2 tane olduğu için ben bir tanesini değiştirmişim.
Bilmeliydim ki başlıkta Halit Bey var.:kafa:

Kod tek kelime ile muhteşem üstad.
Binlerce kez teşekkür ederim.
Açılan pencerede sadece Bilgisayarım > D sürücüsündeki klasörler gözüksün
istiyorum. Bunu yapabilirseniz ne ala.
Olmuyor ise canınız sağolsun.

Saygılarımla.
 
Bora K' Alıntı:
Üstad kendimi aptal gibi hissediyorum.
"ok" ile ilgili sorun yokmuş. Ben "Ok" yazısını "ok" ile değiştirmiştim.
"Ok" 2 tane olduğu için ben bir tanesini değiştirmişim.
Bilmeliydim ki başlıkta Halit Bey var.:kafa:

Kod tek kelime ile muhteşem üstad.
Binlerce kez teşekkür ederim.
Açılan pencerede sadece Bilgisayarım > D sürücüsündeki klasörler gözüksün
istiyorum. Bunu yapabilirseniz ne ala.
Olmuyor ise canınız sağolsun.

Saygılarımla.
Genişletmek için tıkla ...

D sürücüsü gözükmez ama klasör yolunu siz belirliyebilirsiniz.

Kod: 
Sub verikayityap()
Kaynak = "[COLOR=red]D:\deneme[/COLOR]"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Halit Bey;
Tekrardan binlerce teşekkürler.

İyiki varsınız.
 
halit3' Alıntı:
Kodun bu bölümü fazla
Kod: 
aranan3 = ThisWorkbook.Worksheets("liste").Cells(i, "h").Value
Genişletmek için tıkla ...

Halit Bey Merhaba.

Sizi tekrardan rahatsız ediyorum. Lütfen mazur görünüz.
Koda bağlı olarak epey bir çalışma yapacağım. Sonradan meydana
çıkacak bir hata benim çalışmalarımın boşa gitmesine yol açabilir.
Kendim düzeltmeye çalıştım lakin başaramadım. Beynim çorba olmuş durumda.

Yukarıdaki satırı silerek ve ona bağlı aşağıdaki "aranan3" kısımlarını değiştirerek.
4. nolu mesajınızı güncelleyebilirseniz çok sevinirim. Teşekkürler.
 
Bora K' Alıntı:
Halit Bey Merhaba.

Sizi tekrardan rahatsız ediyorum. Lütfen mazur görünüz.
Koda bağlı olarak epey bir çalışma yapacağım. Sonradan meydana
çıkacak bir hata benim çalışmalarımın boşa gitmesine yol açabilir.
Kendim düzeltmeye çalıştım lakin başaramadım. Beynim çorba olmuş durumda.

Yukarıdaki satırı silerek ve ona bağlı aşağıdaki "aranan3" kısımlarını değiştirerek.
4. nolu mesajınızı güncelleyebilirseniz çok sevinirim. Teşekkürler.
Genişletmek için tıkla ...

4 nolu mesajdaki kodu düzelttim.
 
Sayın Özdemir;
Kod tek kelime ile muhteşem oldu.
Elinize zihninize sağlık.
 
Merhaba Halit Bey

4. Nolu mesajdaki makromuzda küçük bir sorun var.
Bazı veriler birden fazla kapalı dosyaya yazılması gerekiyor iken
sadece bir tanesine yazılıyor.

Bu durumu düzeltebilirseniz çok sevinirim.
Ekli dosyada daha detaylı antattım durumu.
Saygılarımla.
 

Ekli dosyalar

Bora K' Alıntı:
Merhaba Halit Bey

4. Nolu mesajdaki makromuzda küçük bir sorun var.
Bazı veriler birden fazla kapalı dosyaya yazılması gerekiyor iken
sadece bir tanesine yazılıyor.

Bu durumu düzeltebilirseniz çok sevinirim.
Ekli dosyada daha detaylı antattım durumu.
Saygılarımla.
Genişletmek için tıkla ...

Buradaki sorun Ok kontrolünden kaynaklanıyor birinci dosyaya veriyi kayıt yaparken ana dosyaya kayıt yaptıktan sonra ok işaretini koyuyor daha sonraki dosyaya kayıt yapacağı zaman anadosyaya ok kontrolune bakıyor varsa atlıyor ve kayıtı yapmıyor.

ok kontrolü ana dosyada olmaz zaten diğer dosyaların içinde olması gerekiyor. 9 nolu mesajdaki koda bir bakın
 
Merhaba.
Halit Bey. 9. nolu mesajda Kod "Ok" kontrollerini kapalılarda yapıyor.
Kapalıları açıp kontrol etmek verileri elle yazmakla eşdeğer olur hemen hemen:(
Makromuz da cazibesini yitirir bu durumda.

Ben kendimce şu şekilde olabilir diye düşünüyorum ama koda dökemiyorum :
Veri aktarmak için ilk önce açık dosya ile kapalı dosyalarda D ve F sütunlarının eşitliğini arıyoruz
D ve F sütununun eşitliği sağlandığında ondan sonra aktarma işlemlerine başlıyoruz.

D ve F sütununun her iki dosyada da (kapalı ve açık) eşitliği sağlandığı durumda;
M sütunu kontrol edilse M sütunu dolu ise ( "Ok" yazıyorsa ) döngü sonlansa. Boş ise
ondan sonra aktarma işlemine devam etse...
 
halit3' Alıntı:
Buradaki sorun Ok kontrolünden kaynaklanıyor birinci dosyaya veriyi kayıt yaparken ana dosyaya kayıt yaptıktan sonra ok işaretini koyuyor daha sonraki dosyaya kayıt yapacağı zaman anadosyaya ok kontrolune bakıyor varsa atlıyor ve kayıtı yapmıyor.

ok kontrolü ana dosyada olmaz zaten diğer dosyaların içinde olması gerekiyor. 9 nolu mesajdaki koda bir bakın
Genişletmek için tıkla ...

Halit Bey kusura bakmayın pm kapalı olduğu için buradan ulaşmak zorunda kaldım.

http://www.excel.web.tr/f48/klasorden-dosya-kopyalama-t125143/sayfa3.html

bahsedilen konu hakkında verdiğiniz paylaşıma belirttiğim gibi bi ek yapmamız mümkün müdür acaba?
Teşekkür ederim iyi akşamlar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst