Aylık Tarih Kontrolü..

[tirEdsOuL]

Bir çalışmam için Ömer Hocamızın yapmış olduğu aşağıdaki kodu ben başka bir tabloma daha uyarladım sütun isimlerini değiştirip.. ama bu tablomda şöyle de birşey var, ben müşterileri aylık dosyalar halinde tutuyorum.. Aşağıdaki kodda Eğer Sayfa1 "G" sütununda B harfi varsa şu hücreleri Sayfa2 deki şu hücrelere aktar diyor, güzelde çalışıyor bu şekli ile.. ama aynı zamanda da "O" hücresindeki fatura tarihini kontrol edip, o ayın satışlarını getirmesini istiyorum Sayfa2'ye.. yani Sayfa1'deki "G" hücresindeki B harflarini bulacak ve aynı zamanda O hücresindeki Fatura tarihine bakıp bu ayki satış ise Sayfa 2'ye geçirecek belirttiğim hücreleri.. mümkün müdür acaba?

Saygılar..

Sub Guncelle()
 
    Dim i As Long, sat As Long, c As Range
    Dim Adr As Variant, Sa As Worksheet
    
    Set Sa = Sheets("Sayfa1")
    
    Application.ScreenUpdating = False
    
    For i = Cells(Rows.Count, "G").End(xlUp).Row To 2 Step -1
        With Sa.Range("G:G")
          Set c = .Find(Cells(i, "G"), , xlValues, xlWhole)
            If Not c Is Nothing Then
              Adr = c.Address
                Do
                  If Sa.Cells(c.Row, "G") = "B" Then
                    Rows(i).Delete
                  End If
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            Else
                Rows(i).Delete
            End If
        End With
    Next i
 
    sat = Cells(Rows.Count, "G").End(xlUp).Row + 1
    For i = 2 To Sa.Cells(Rows.Count, "A").End(xlUp).Row
        If Sa.Cells(i, "G") = "B" Then
        Set c = Range("G:G").Find(Sa.Cells(i, "G"), , xlValues, xlWhole)
            If c Is Nothing Then
                Cells(sat, "A") = sat - 2
                Cells(sat, "B") = Sa.Cells(i, "P")
                Cells(sat, "F") = Sa.Cells(i, "O")
                Cells(sat, "E") = Sa.Cells(i, "H")
                sat = sat + 1
            End If
        End If
    Next i
    
    Range("A2") = 1
    Range("A2").DataSeries xlColumns, xlLinear, xlDay, 1, sat - 2
 
    Set c = Nothing: Set Sa = Nothing
 
    Application.ScreenUpdating = True
 
End Sub

 

[Ömer]

Merhaba,

Sorunuzu küçük bir örnek dosya ile destekleyip detaylı açıklarmısınız.

 

[tirEdsOuL]

Dosya Ektedir, konuda belirtmeyi unutmuşum ekte de açıkladım, ben işlemlerimi farklı bir çalışma kitabında yapmak istiyorum.. Aylık olarak kitaplar halinde..

 

[Ömer]

Dosya Ektedir, konuda belirtmeyi unutmuşum ekte de açıkladım, ben işlemlerimi farklı bir çalışma kitabında yapmak istiyorum.. Aylık olarak kitaplar halinde..

Farkı kitapla ilgili sorunuz için yeni konu başlığı açamanızı rica ederim. İlaveyi kırmızı ile işaretledim.

Sub Guncelle()
 
    Dim i As Long, sat As Long, c As Range
    Dim Adr As Variant, Sa As Worksheet
 
    Set Sa = Sheets("Satislar")
 
    Application.ScreenUpdating = False
 
    For i = Cells(Rows.Count, "G").End(xlUp).Row To 2 Step -1
        With Sa.Range("G:G")
          Set c = .Find(Cells(i, "G"), , xlValues, xlWhole)
            If Not c Is Nothing Then
              Adr = c.Address
                Do
                  If Sa.Cells(c.Row, "G") = "B" Then
                    Rows(i).Delete
                  End If
                Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            Else
                Rows(i).Delete
            End If
        End With
    Next i
 
    sat = Cells(Rows.Count, "G").End(xlUp).Row + 1
    For i = 2 To Sa.Cells(Rows.Count, "A").End(xlUp).Row
        If Sa.Cells(i, "G") = "B" Then
        Set c = Range("G:G").Find(Sa.Cells(i, "G"), , xlValues, xlWhole)
            If c Is Nothing Then
                [COLOR=red]If Format(Sa.Cells(i, "O"), "mm") = Format(Date, "mm") Then[/COLOR]
                    Cells(sat, "A") = sat - 2
                    Cells(sat, "B") = Sa.Cells(i, "P")
                    Cells(sat, "F") = Sa.Cells(i, "O")
                    Cells(sat, "E") = Sa.Cells(i, "H")
                    sat = sat + 1
                [COLOR=red]End If[/COLOR]
            End If
        End If
    Next i
 
    Range("A2") = 1
    Range("A2").DataSeries xlColumns, xlLinear, xlDay, 1, sat - 2
 
    Set c = Nothing: Set Sa = Nothing
 
    Application.ScreenUpdating = True
 
End Sub

.