• DİKKAT

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

Mükerrer olan veriyi koşula göre almaması

N

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,238
Excel Vers. ve Dili
Ofis 2013 Türkçe
Merhaba arkadaşlar
Ekli dosyada Korhan hocamın yardımı ile hazırlanmış dosyada modül 1 de kodlar
var
Başka dosyadan veriler alıyorum veri alırken A sutununa gelen veriler ile bire bir eşleşen başka veriler varsa ve G sutununa gelen veriler (o) veya boşsa bu satırdaki verlerin tamamını (A:G arasını) almayacak.
Yok A sutununa gelen veri bir tane ve eşleşen başka veri yoksa G sutununa gelen veri (0) veya boşsada alacak şekilde nasıl düzenleye biliriz?
 

Ekli dosyalar

Son düzenleme:
Arkadaşlar bu konuda bir fikri olan varmı?
 
numan şamil' Alıntı:
Merhaba arkadaşlar
Ekli dosyada Korhan hocamın yardımı ile hazırlanmış dosyada modül 1 de kodlar
var
Başka dosyadan veriler alıyorum veri alırken A sutununa gelen veriler ile bire bir eşleşen başka veriler varsa ve G sutununa gelen veriler (o) veya boşsa bu satırdaki verlerin tamamını (A:G arasını) almayacak.
Yok A sutununa gelen veri bir tane ve eşleşen başka veri yoksa G sutununa gelen veri (0) veya boşsada alacak şekilde nasıl düzenleye biliriz?
Genişletmek için tıkla ...

Selam,

Yanlış anlamadıysam, Module1'de kodlarını aşağıdaki gibi dener misiniz?
Kod: 
Sub OcakAktar()
      Dim Klasör As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim Satır As Long, Dosya As Object, Kaynak_Dosya As Object, Sayfa As Worksheet
 
    On Error GoTo Son
 
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
 
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Raporlama")
 
    Dosya_Yolu = Klasör.Items.Item.Path
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
    Veri_Dosyası.Sheets("Raporlama").Range("A2:G" & Rows.Count).ClearContents
 
    Satır = 2
 
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
        If Dosya.Name <> Veri_Dosyası.Name Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
            For Each Sayfa In Kaynak_Dosya.Worksheets
                If Sayfa.Index > Kaynak_Dosya.Sheets("ilk sayfa").Index And _
                Sayfa.Index < Kaynak_Dosya.Sheets("son sayfa").Index Then
                
                If WorksheetFunction.CountIf(SR.Range("A2:A" & Satır), Sayfa.Range("H2")) > 0 _
                And (Sayfa.Range("J6") = 0 Or Sayfa.Range("J6") = "") Then GoTo atla
                
                    SR.Cells(Satır, 1) = Sayfa.Range("H2")
                    SR.Cells(Satır, 2) = Sayfa.Range("B2")
                    SR.Cells(Satır, 3) = Sayfa.Range("C8")
                    SR.Cells(Satır, 4) = Sayfa.Range("D8")
                    SR.Cells(Satır, 5) = Sayfa.Range("E8")
                    SR.Cells(Satır, 6) = Sayfa.Range("F8")
                    SR.Cells(Satır, 7) = Sayfa.Range("J6")
                    Satır = Satır + 1
atla:
                End If
            Next
 
            Kaynak_Dosya.Close True
        End If
    Next
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
 
Son:
    Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

İyi çalışmalar.
 
Son düzenleme:
Merhaba ergün bey
ilginize teşekkürler
kodlarınızı denedim herhani bir değişiklik göremedim yanlış anlamadıysam kodlarda "If WorksheetFunction.CountIf(SR.Range("A2:A" & Satır), Sayfa.Range("H2")) > 0 _
And (Sayfa.Range("J6") = 0 Or Sayfa.Range("J6") = "") Then GoTo atla"
[("H2")) > 0 değilde,]
Aşağıda örneğini verdiğim H sutununa gelen veriler bire bir aynı ise ve bu iki örnekten j sutununda "0" yazan satırın tamamını almayacak
H - B - C - D - E - F - J
125879 - X FİRMASI -3546.45 - 956 - 1098.8 - 5601.25
125879 - X FİRMASI - - - - - 0
Ancak
125879 - X FİRMASI - 3546.45 - 956 -1098.8 - 5601.25
357265 - X FİRMASI - - - - 0
durumunda ise her ikisinide alacak
iyi çalışmalar
 
Son düzenleme:
numan şamil' Alıntı:
Merhaba ergün bey
ilginize teşekkürler
kodlarınızı denedim herhani bir değişiklik göremedim
Genişletmek için tıkla ...
Değişikliği niye göremiyorsunuz? ben size aynı kodları mı yolluyorum?

Daha sonra ise, aşağıdaki kırmızı alan eklediğimi fark ediyorsunuz.

Kod: 
For Each Sayfa In Kaynak_Dosya.Worksheets
                If Sayfa.Index > Kaynak_Dosya.Sheets("ilk sayfa").Index And _
                Sayfa.Index < Kaynak_Dosya.Sheets("son sayfa").Index Then
                
[COLOR="Red"]                If WorksheetFunction.CountIf(SR.Range("A2:A" & Satır), Sayfa.Range("H2")) > 0 _
                And (Sayfa.Range("J6") = 0 Or Sayfa.Range("J6") = "") Then GoTo atla[/COLOR]                
                    SR.Cells(Satır, 1) = Sayfa.Range("H2")
                    SR.Cells(Satır, 2) = Sayfa.Range("B2")
                    SR.Cells(Satır, 3) = Sayfa.Range("C8")
                    SR.Cells(Satır, 4) = Sayfa.Range("D8")
                    SR.Cells(Satır, 5) = Sayfa.Range("E8")
                    SR.Cells(Satır, 6) = Sayfa.Range("F8")
                    SR.Cells(Satır, 7) = Sayfa.Range("J6")
                    Satır = Satır + 1
atla:
                End If
            Next
Kırmızı alan bize neyi anlatıyor?:

Döngüye aldığınız sayfanın H2'sindeki veri, eğer daha önce eklenmiş ise ve J2'si 0 ise bunu ekleme demek. Biraz daha açalım:

H2 verisi nereye gidiyor? SR sayfasının A sütununa. Örnek dosyanızdaki "40090102" verisidir.
daha sonra döngü devam ediyor.
yine bir "40090102" verisi geliyor. SR sayfasının A sütununda sayıyor. CounIf soucu 1 çıkıyor. Daha sonra J6'ya bakıyor. J6 sıfır (0) ise. bu satırı eklemiyor.

Kaynak dosyanız olmadan ancak bu kadar anlıyorum kusura bakmayınız.
Çözüm talebiniz ile aynıdır.
Çözüm bulunamıyorsa tam olarak ifade edememişsiniz demektir.
Aşağıda örneğini verdiğim H sutununa gelen veriler bire bir aynı ise ve bu iki örnekten j sutununda "0" yazan satırın tamamını almayacak
H - B - C - D - E - F - J
125879 - X FİRMASI -3546.45 - 956 - 1098.8 - 5601.25
125879 - X FİRMASI - - - - - 0
Ancak
125879 - X FİRMASI - 3546.45 - 956 -1098.8 - 5601.25
357265 - X FİRMASI - - - - 0
durumunda ise her ikisinide alacak
iyi çalışmalar
Genişletmek için tıkla ...

İfadeleriniz çok karışık. Ne istediğiniz tam anlaşılmıyor. Yöntemini size verdim. üzerinde biraz oynayarak isteğinizi kendiniz de gerçekleştirebilirsiniz. Sayıları metin, metinleri sayı görüyor olabilir. Kaynak sayfada H2 verisinin formatı ile SR sayfasının A sütunundaki format aynı mı değil mi onlara bir bakın.
 
Merhaba Ergün bey
Beni yanlış anladınız daha doğrusu ben anlatamadım değişiklik göremedim derken göndermiş olduğunuz kodlarda değişiklik yok manasında kullanmadım uygulamam sonucunda veri aktarımında değişiklik olmadı demek istemiştim. kullandığım ifade acele ile yazıldığı için biraz yarım ve ("kodlarınızı denedim herhani bir değişiklik göremedim") şeklinde oldu özür dilerim.
Ayrıca CountIf(SR.Range("A2:A" & Satır), Sayfa.Range("H2")) > 0 _
And (Sayfa.Range("J6") = 0 Or Sayfa.Range("J6") = "") Then GoTo atla"
ifadesini kod bilmediğimden dolayı H2 sıfırdan büyük ve J 6 sıfıra eşitse j6 yı boş bırak şeklinde yorumladım. "H2 ile bire bir eşleştiğinde" vurgulamak istemiştim buda kodları kavrıyamadığımdan ve öğrenme isteğimden kaynaklanmıştır.
Konunun anlaşılması için ekte gönderdiğim dosyada modül 1'e kodlarınızı kopyaladım ve dosyalarımın bir örneği olan iki dosya gönderiyorum aktar butonuna basılınca verilerin nasıl geldiği gözükecektir kısa bir açıklamada yaptım kalp kırdıysam hakkınızı helal edin
İyi çalışmalar
 

Ekli dosyalar

Son düzenleme:
numan şamil' Alıntı:
Merhaba Ergün bey
..............oldu özür dilerim........ kalp kırdıysam hakkınızı helal edin
İyi çalışmalar
Genişletmek için tıkla ...

Selam,
Sizi kırdıysam. asıl ben özür dilerim. Siz de hakkınızı helal ediniz.
Çözüme gelince;

Module2 ekleyiniz. Bu boş modüle aşağıdaki kodu yapıştırınız.
Kod: 
Sub kosullu_sil()
Dim rpr As Worksheet
Set rpr = ThisWorkbook.Worksheets("Raporlama")
Dim bulunan As Range
Dim aralik As Range

rpr_son = rpr.Range("A65536").End(3).Row
Set aralik = rpr.Range("A2:A" & rpr_son)

sat = 2
For i = 2 To rpr_son
aranan = rpr.Cells(sat, "A").Address

say = Evaluate("=SUMPRODUCT((" & aranan & "=" & aralik.Address & ")*1)")

If say > 1 And rpr.Cells(sat, "G") = 0 Then
'rpr.Rows(sat).Delete Shift:=xlUp
rpr.Range("A" & sat & ":G" & sat).Delete Shift:=xlUp
Else
sat = sat + 1
End If

Next
End Sub

daha sonra module1'deki Sub OcakAktar() adlı kodlarınızın aşağıdaki kısmına kırmızı kodu yapıştırınız.
Kod: 
atla:
                End If
            Next
 
            Kaynak_Dosya.Close True
        End If
    Next
[B][COLOR="Red"] Call kosullu_sil[/COLOR][/B]
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
 
Son:
    Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
İyi çalışmalar.
 
Çok teşekkür ederim tam istediğim gibi oldu.
Sayenizde bu konuda bilgi edinmiş oldum hakkınızı helal edin
İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst