• DİKKAT

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

Farklı dosyalardan veriyi süzerek almak

  • Konbuyu başlatan Konbuyu başlatan Jeeday
  • Başlangıç tarihi Başlangıç tarihi
J

Jeeday

Katılım
7 Mayıs 2006
Mesajlar
367
Excel Vers. ve Dili
2019 İngilizce
Farklı dosyaların içinden, istediğimiz çalışma kitabının istediğimiz alanındaki verileri süzerek başka bir dosyaya sıralamak istiyorum...

Örnekte 7 tane dosya var.

'[Set 2011.xlsm]Stok2011'!A3:A500
'[Set 2012.xlsm]Stok2012'!A3:A500
'[Set 2013.xlsm]Stok2013'!A3:A500
'[Set 2014.xlsm]Stok2014'!A3:A500
'[Set 2015.xlsm]Stok2015'!A3:A500
'[Set 2016.xlsm]Stok2016'!A3:A500

bu tablolardaki verileri süzüp

'[Set Giriş - Çıkış.xlsm]Set Giriş - Çıkış'!A3'ten itibaren listelemek istiyorum.

1. Dosyalar kapalı iken bu mümkün mü?
2. Set 2017, Set 2018 vb. gibi yeni dosyalar olduğunda da bu işlem hepsini kapsasın....
 

Ekli dosyalar

  • Set.zip
    Set.zip
    420.1 KB · Görüntüleme: 25
Merhaba
Neyi süzerek aktaracak onu anlamadım :(
 
'[Set 2011.xlsm]Stok2011'!A3:A500
'[Set 2012.xlsm]Stok2012'!A3:A500
'[Set 2013.xlsm]Stok2013'!A3:A500
'[Set 2014.xlsm]Stok2014'!A3:A500
'[Set 2015.xlsm]Stok2015'!A3:A500
'[Set 2016.xlsm]Stok2016'!A3:A500

'[Set ****.xlsm] dosya adları
Stok**** dosyadaki sayfa adı
A3:A500 dosyadaki sayfanın süzülmek istenen yeri

6 tane dosyayı birleştirip süzecek yani
 
Jeeday' Alıntı:
'[Set 2011.xlsm]Stok2011'!A3:A500
'[Set 2012.xlsm]Stok2012'!A3:A500
'[Set 2013.xlsm]Stok2013'!A3:A500
'[Set 2014.xlsm]Stok2014'!A3:A500
'[Set 2015.xlsm]Stok2015'!A3:A500
'[Set 2016.xlsm]Stok2016'!A3:A500

'[Set ****.xlsm] dosya adları
Stok**** dosyadaki sayfa adı
A3:A500 dosyadaki sayfanın süzülmek istenen yeri

6 tane dosyayı birleştirip süzecek yani
Genişletmek için tıkla ...

Yani bu dosyalardaki A3:A500 aralığını tek dosyada mı birleştirecek demek istiyorsunuz.
Konu başlığına süzme yazmışsınız ondan soruyorum. Süzecek bir veri göremedim de :)
 
Dosyaları açtığınızda her dosyada "Stok ****" adında sayfalar var. Bu sayfalardaki A3:A500 alanındaki verilerin bazıları diğer sayfaların A3:A500 alanlarında da var. Bunları toplayıp, süzüp yeni bir dosyada birleştirecek.. Şu an için veriler az... Çok yüklü veri girişi oluyor zamanla...
 
Jeeday' Alıntı:
Dosyaları açtığınızda her dosyada "Stok ****" adında sayfalar var. Bu sayfalardaki A3:A500 alanındaki verilerin bazıları diğer sayfaların A3:A500 alanlarında da var. Bunları toplayıp, süzüp yeni bir dosyada birleştirecek.. Şu an için veriler az... Çok yüklü veri girişi oluyor zamanla...
Genişletmek için tıkla ...

Yani sizin istediğiniz tüm dosyalardaki tüm veriler olsun ama mükerrer olanlar üst üste toplansın istiyorsunuz anladığım kadarı ile doğru mu_?
 
Tüm a3:a500 lerdeki veriler tek bir listeye alınsın, mükerrer olanlar sadece 1 tane olsun....
 
Jeeday' Alıntı:
Tüm a3:a500 lerdeki veriler tek bir listeye alınsın, mükerrer olanlar sadece 1 tane olsun....
Genişletmek için tıkla ...

Boş bir module kopyalayın ve deneyin.
Kod: 
Option Explicit
Sub veri_çek_birleştir_1967()
Dim XCL As Application, KTP As Workbook, YOL As String, SY As String
Dim STR As Long, S1 As Worksheet, S2 As Worksheet, DSY As String, ÇLŞ As Variant
Set XCL = CreateObject("Excel.Application")
XCL.Visible = False
YOL = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Set S1 = ActiveSheet
ÇLŞ = ActiveCell.Address
S1.Range("A3:F" & Rows.Count).ClearContents
DSY = Dir(YOL & "*.xlsm?")
Do While DSY <> ""
If DSY <> ActiveWorkbook.Name Then
Set KTP = XCL.Workbooks.Open(YOL & DSY)
SY = Replace(Replace(DSY, "Set", "Stok"), ".xlsm", "")
Set S2 = KTP.Sheets(SY)
STR = S1.Range("A" & Rows.Count).End(xlUp).Row + 1
S2.Range("A3:F500").Copy
S1.Range("A" & STR).PasteSpecial (xlPasteValues)
KTP.Save: KTP.Close 0: XCL.Quit
End If: DSY = Dir
Loop
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "asi_kral_1967"
Set S2 = ActiveSheet
STR = S1.Range("A" & Rows.Count).End(xlUp).Row
S1.Range("A2:A" & STR).AdvancedFilter xlFilterCopy, S1.Range("A2:A" & STR), S2.Range("A1"), True
STR = S2.Range("A" & Rows.Count).End(xlUp).Row
S2.Range("B2:F" & STR) = "=SUMIF('Stok Giriş - Çıkış'!$A:$A,$A2,'Stok Giriş - Çıkış'!B:B)"
S2.Range("B2:F" & STR) = S2.Range("B2:F" & STR).Value
S1.Range("A3:F" & Rows.Count).ClearContents
S2.Range("A2:F" & STR).Copy
S1.Range("A3").PasteSpecial (xlPasteValues)
Application.DisplayAlerts = False
S2.Delete
Application.DisplayAlerts = True
S1.Range(ÇLŞ).Select
Application.ScreenUpdating = True
End Sub
 
bu kodu "Set Giriş - Çıkış.xlsm" dosyasının içindeki sayfada kullanmak istiyorum yanlız.... ve sonucu burada görmek istiyorum. Denedim hatalar veriyor
 
Son düzenleme:
ve ayrıca yanlardaki adetleri hesaplamasını istemiyorum. sadece stok kodlarını ayarlasın yeter bana....
 
zahmet veriyorum ama :(

tmm bende de çalıştı... ama dediğim gibi adetleri hesaplamasın... sadece kodlar yeterli
 
Jeeday' Alıntı:
ve ayrıca yanlardaki adetleri hesaplamasını istemiyorum. sadece stok kodlarını ayarlasın yeter bana....
Genişletmek için tıkla ...

Nasıl yani siz sadece kodları mı istiyorsunuz_? Vıyyyyyyyyyyyyyyyyyyyy
Desene fazladan uğraştık :)
Bu kodu deneyin lütfen.
Kod: 
Option Explicit
Sub veri_çek_birleştir_1967()
Dim XCL As Application, KTP As Workbook, YOL As String, SY As String
Dim STR As Long, S1 As Worksheet, S2 As Worksheet, DSY As String, ÇLŞ As Variant
Set XCL = CreateObject("Excel.Application")
XCL.Visible = False
YOL = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Set S1 = ActiveSheet
ÇLŞ = ActiveCell.Address
S1.Range("A3:A" & Rows.Count).ClearContents
DSY = Dir(YOL & "*.xlsm?")
Do While DSY <> ""
If DSY <> ActiveWorkbook.Name Then
Set KTP = XCL.Workbooks.Open(YOL & DSY)
SY = Replace(Replace(DSY, "Set", "Stok"), ".xlsm", "")
Set S2 = KTP.Sheets(SY)
STR = S1.Range("A" & Rows.Count).End(xlUp).Row + 1
S2.Range("A3:A500").Copy
S1.Range("A" & STR).PasteSpecial (xlPasteValues)
KTP.Save: KTP.Close 0: XCL.Quit
End If: DSY = Dir
Loop
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "asi_kral_1967"
Set S2 = ActiveSheet
STR = S1.Range("A" & Rows.Count).End(xlUp).Row
S1.Range("A2:A" & STR).AdvancedFilter xlFilterCopy, S1.Range("A2:A" & STR), S2.Range("A1"), True
STR = S2.Range("A" & Rows.Count).End(xlUp).Row
S1.Range("A3:A" & Rows.Count).ClearContents
S2.Range("A2:A" & STR).Copy
S1.Range("A3").PasteSpecial (xlPasteValues)
Application.DisplayAlerts = False
S2.Delete
Application.DisplayAlerts = True
S1.Range(ÇLŞ).Select
Application.ScreenUpdating = True
End Sub
 
Yoo kim dedi ki veriyo çalışıyo fıstık gibi :)
 
çok ii çalışıyo da şöyle bi sorun oluştu... bu dosyaların bulunduğu klasörün içinde "2012 Resmi Stok.xlsm" adında bir dosya var. Bu dosya yüzünden hata veriyor. Ne alaka anlayamadım. dosyayı çıkarıyorum o klasörden hata yok oluyor...
 
Jeeday' Alıntı:
çok ii çalışıyo da şöyle bi sorun oluştu... bu dosyaların bulunduğu klasörün içinde "2012 Resmi Stok.xlsm" adında bir dosya var. Bu dosya yüzünden hata veriyor. Ne alaka anlayamadım. dosyayı çıkarıyorum o klasörden hata yok oluyor...
Genişletmek için tıkla ...

Dosyalara göre tanımlamalar yaptım ondan kaynaklanıyor. :)
Siz böyle bir dosya olacağını söylememiştiniz :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst