• DİKKAT

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

2 kapalı dosya arası hücre süzerek kopyalama

S

schlecht

Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Merhaba, 2 kapalı dosya arası veri kopyalama kodları aşağıdaki gibi.
kapalı3 dosyasındaki Sayfa1 B2:B2 deki verileri kapalı1 dosyası Sayfa1 B2 hücresine kopyalamaktadır.

İstedeğim kapalı3 dosyasındaki E sütünündaki değere göre (örneğni: "Diğer" yazanları süzmek gibi) B2:B2 arası verileri kopyalamak ve kapalı1 dosyasındaki B2 hücresine kopyalamak.

Teşekkürler.

Kod: 
Sub AKTAR()
    Dim Excel_Uygulama As Object, Yol As String, Dosya_Adi As String
    Dim K1 As Object, K2 As Object, S1 As Worksheet, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set Excel_Uygulama = CreateObject("Excel.Application")
    Excel_Uygulama.Visible = False
    
    Yol = ThisWorkbook.Path
    
    Dosya_Adi = Yol & "\kapalı3.xlsx"
    Set K1 = Excel_Uygulama.Workbooks.Open(Dosya_Adi)
    
    Dosya_Adi = Yol & "\kapalı1.xlsx"
    Set K2 = Excel_Uygulama.Workbooks.Open(Dosya_Adi)
    Set S1 = K2.Sheets("Sayfa1")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    S1.Range("B2:B2" & Son).Copy K1.Sheets("Sayfa1").Range("B2")
    K2.Close
     
    K1.Save
    K1.Close
    
    Set S1 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
    Set Excel_Uygulama = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Kodlar Korhan Ayhan hocam tarafından yazılmıştır.
 
Merhaba
Yukarıdaki kodlarınızda aşağıdaki gibi değişiklik yaparak deneyebilirsiniz
Kod: 
[SIZE="2"]Sub AKTAR()
    Dim Excel_Uygulama As Object, Yol As String, Dosya_Adi As String
    Dim K1 As Object, K2 As Object, S1 As Worksheet, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set Excel_Uygulama = CreateObject("Excel.Application")
    Excel_Uygulama.Visible = False
    
    Yol = ThisWorkbook.Path
    
    Dosya_Adi = Yol & "\kapalı3.xlsx"
    Set K1 = Excel_Uygulama.Workbooks.Open(Dosya_Adi)
    
    Dosya_Adi = Yol & "\kapalı1.xlsx"
    Set K2 = Excel_Uygulama.Workbooks.Open(Dosya_Adi)
    Set S1 = K2.Sheets("Sayfa1")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
     
 [COLOR="Red"]   K1.Sheets("Sayfa1").Range("B2:B" & rows.count) = Empty
    S1.Range("E1").AutoFilter
S1.Range("E1:E" & Son).AutoFilter Field:=1, Criteria1:="=[COLOR="Blue"]Diğer[/COLOR]", Operator:=xlAnd
S1.Range("B2:B" & Son).SpecialCells(xlCellTypeVisible).Cells.Copy K1.Sheets("Sayfa1").Range("B2")
    
    K2.Close Savechanges:=False[/COLOR]
     
    K1.Save
    K1.Close
    
    Set S1 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
    Set Excel_Uygulama = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
[/SIZE]
 
Son düzenleme:
İlginize çok teşşekür ederim. kapalı1 ile kapalı3 dosya yerlerini yanlış yazmışım.

kapalı1 dosyasındaki E sütünündaki değere göre (örneğin: "Diğer" yazanları süzmek gibi) B2:B2 arası verileri kopyalamak ve kapalı3 dosyasındaki B2 hücresine kopyalamak istiyorum değiştirmeye çalıştım fakat başaramadım.
Yardımcı olursanız sevinirim. Teşekkürler.

Not: Kodlar açık olan 3. bir sayfada çalıştıralacaktır.
 
Son düzenleme:
schlecht' Alıntı:
kapalı1 dosyasındaki E sütünündaki değere göre (örneğin: "Diğer" yazanları süzmek gibi) B2:B2 arası verileri kopyalamak ve kapalı3 dosyasındaki B2 hücresine
Genişletmek için tıkla ...
Merhaba
Kodlar ek dosyadaki gibi "kapalı1" dosyasında bulunan "E" sütununda "diğer" yazan satırları süzüp
süzülen "B" sütunundaki dolu hücreleri "kapalı3" dosyası, "B" sütununa aktarıyor.
http://www.dosya.tc/server12/sgpqa3/deneme.zip.html
Mesajınızda sadece bir hücreyi belirtmişsiniz (B2:B2) "B2" hücresi burada bir yanlışlık varmı?
Dosyayı denermisiniz? Öyle değilse bir örnek eklersiniz.
 
Sayın PLİNT, yardımlarınız için çok teşekkür ederim. Kusursuz çalışıyor. Formülde B2:B2 yazdım belirli bir aralık belirmek için, formülü değişik sayfalarda kullanıyorum B2:B4, B2:B8... olarak değiştiriyorum.
 
PLİNT' Alıntı:
Merhaba
Yukarıdaki kodlarınızda aşağıdaki gibi değişiklik yaparak deneyebilirsiniz
Kod: 
[SIZE="2"]Sub AKTAR()
    Dim Excel_Uygulama As Object, Yol As String, Dosya_Adi As String
    Dim K1 As Object, K2 As Object, S1 As Worksheet, Son As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set Excel_Uygulama = CreateObject("Excel.Application")
    Excel_Uygulama.Visible = False
   
    Yol = ThisWorkbook.Path
   
    Dosya_Adi = Yol & "\kapalı3.xlsx"
    Set K1 = Excel_Uygulama.Workbooks.Open(Dosya_Adi)
   
    Dosya_Adi = Yol & "\kapalı1.xlsx"
    Set K2 = Excel_Uygulama.Workbooks.Open(Dosya_Adi)
    Set S1 = K2.Sheets("Sayfa1")
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    
[COLOR="Red"]   K1.Sheets("Sayfa1").Range("B2:B" & rows.count) = Empty
    S1.Range("E1").AutoFilter
S1.Range("E1:E" & Son).AutoFilter Field:=1, Criteria1:="=[COLOR="Blue"]Diğer[/COLOR]", Operator:=xlAnd
S1.Range("B2:B" & Son).SpecialCells(xlCellTypeVisible).Cells.Copy K1.Sheets("Sayfa1").Range("B2")
   
    K2.Close Savechanges:=False[/COLOR]
    
    K1.Save
    K1.Close
   
    Set S1 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
    Set Excel_Uygulama = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
[/SIZE]
Genişletmek için tıkla ...

kodda bir yanlışlık mı var çözemedimde dosyada silinmiş. Sadece ilk satırı koopyalıyor.
 
Merhaba
Ek dosyayı deneyin
https://www.dosyaupload.com/jt9M
Kod: 
Sub AKTAR()
    Dim Excel_Uygulama As Object, Yol As String, Dosya_Adi As String
    Dim K1 As Object, K2 As Object, S1 As Worksheet, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set Excel_Uygulama = CreateObject("Excel.Application")
    Excel_Uygulama.Visible = False
    
    Yol = ThisWorkbook.Path
    
    Dosya_Adi = Yol & "\kapalı3.xlsx"
    Set K1 = Excel_Uygulama.Workbooks.Open(Dosya_Adi)
    
    Dosya_Adi = Yol & "\kapalı1.xlsx"
    Set K2 = Excel_Uygulama.Workbooks.Open(Dosya_Adi)
    Set S1 = K2.Sheets("Sayfa1")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    
K1.Sheets("Sayfa1").Range("B2:B" & Rows.Count) = Empty
    S1.Range("E1").AutoFilter
S1.Range("E1:E" & Son).AutoFilter Field:=5, Criteria1:="Diğer", Operator:=xlAnd
S1.Range("B2:B" & Son).SpecialCells(xlCellTypeVisible).Cells.Copy K1.Sheets("Sayfa1").Range("B2")
    
    K2.Close Savechanges:=False
    
    K1.Save
   K1.Close
    Excel_Uygulama.Quit
    Set S1 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
    Set Excel_Uygulama = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Teşekkürler... Son bir sorum olacak.

K1.Sheets("Sayfa1").Range("B2:B" & Rows.Count) = Empty
S1.Range("E1").AutoFilter
S1.Range("E1:E" & Son).AutoFilter Field:=5, Criteria1:="Diğer", Operator:=xlAnd
S1.Range("B2:B" & Son).SpecialCells(xlCellTypeVisible).Cells.Copy K1.Sheets("Sayfa1").Range("B2")

sola hizalanmış şekilde nasıl akatırım. Çok denedim sürekli hata aldım. Sanırım seçimi yapamdım.
 
Merhaba
"B2,C2,D2........." gibi sağa doğru yazmasını istiyorsanız;
Aşağıdaki sadece şu satırı silin
Kod: 
S1.Range("B2:B" & Son).SpecialCells(xlCellTypeVisible).Cells.Copy K1.Sheets("Sayfa1").Range("B2")

yerine;
Kod: 
For Each n In S1.Range("B2:B" & Son).SpecialCells(xlCellTypeVisible).Cells
K1.Sheets("Sayfa1").Cells(2, b + 2) = n.Value
b = b + 1
Next
 
Teşekkür ederim.

Saattir uğraşıyorum anlam veremediğim bir olay var.

S1.Range("I1").AutoFilter
S1.Range("I1:I" & Son).AutoFilter Field:=5, Criteria1:="Örnek Kullandırım Oranı: Düşük", Operator:=xlAnd

I sutununda filte yapamıyorum, acaba Criteria1 den mi aynı Criteria1 i e sutununda sorunsuz buluyor.

Criteria1 de içeren gibi bir şey olarabilir mi? Düşük kelimesini içeren gibi
 
Şöyle deneyiniz
S1.Range("I1:I" & Son).AutoFilter Field:=9, .......... xland

Ayrıca, yukarıda kodların başına
"on error resume next" ekleyin diğer dosyalar gizli açıldığından; filtrelenecek veri bulunamazsa hata verip dosyalar açık kalmasın
veya son kullandığınız kodları eklerseniz arama kodları yazalım
 
PLİNT' Alıntı:
Şöyle deneyiniz
S1.Range("I1:I" & Son).AutoFilter Field:=9, .......... xland

Ayrıca, yukarıda kodların başına
"on error resume next" ekleyin diğer dosyalar gizli açıldığından; filtrelenecek veri bulunamazsa hata verip dosyalar açık kalmasın
veya son kullandığınız kodları eklerseniz arama kodları yazalım
Genişletmek için tıkla ...
Gerçekten teşekkür ederim. 2 saattir. Çözememiştim.

Kusura bakmayın, "on error resume next" bu kodu nereye ekleyeceğimi anlamadım.
 
Sub AKTAR()
on error resume next
'...
'.......


gibi olabilir
aslında makronun içeriğine kodlar eklenip veri bulundu, bulunamadı gibi mesaj verdirilebilir
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst