Skip to main content

AccessTr.neT

Kayıt Ol

 | Facebook ile Bağlan  | Twitter İle Bağlan | Google+ İle Bağlan

Rucü Davaları Yüklenici Ödemeleri

cdenktas
cdenktas
Excel Cevaplanmış Soruları
22
805

Rucü Davaları Yüklenici Ödemeleri

#22
cdenktas
Aktif Üye
cdenktas
Bul
Aktif Üye
Adı Soyadı:
Yaşı: 45
Konum: -
Ofis Versiyonu: -
Son Oturumu: 22/04/2024,15:26
Yorumları: 161
Konuları: 37
Kayıt Tarihi: 19/09/2019
Teşekkür Puanı: 0
(22/11/2023, 18:38)feraz yazdı: Kodu Rücu  sayfanın kod bölümüne ekleyin.
Tarihler ve Gürevi(I1) değişince kodçalışır.


Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, ii As Long, son As Long, say As Long
    Dim syf As Worksheet, aralik(), kac As Long, syfRucu As Worksheet
    Dim b2 As Long, f2 As Long, I1 As String, ilktrh As Long, sontrh As Long
   
   
    If Not Intersect(Target, Range("B2,F2,I1")) Is Nothing Then
        Set syfRucu = ThisWorkbook.Worksheets("Rucü Yüklenici")
        b2 = Cells(2, "B").Value2: f2 = syfRucu.Cells(2, "F").Value2: I1 = syfRucu.Cells(1, "I").Value2
        Union(syfRucu.Range("B5:C" & Rows.Count), syfRucu.Range("E5:E" & Rows.Count)).Value = ""
        If Len(Trim(b2)) > 1 And Trim(b2) > 0 And Trim(f2) > 0 And Len(Trim(f2)) > 1 And Len(Trim(I1)) > 0 Then
            On Error Resume Next
            Set syf = ThisWorkbook.Worksheets(Range("I1").Value)
            On Error GoTo 0
            say = 1
            For i = syfRucu.Cells(2, "B").Value2 To (syfRucu.Cells(2, "F").Value2)
                ReDim Preserve aralik(1 To say)
                aralik(say) = i: say = say + 1
            Next
            say = 5
            If Not syf Is Nothing Then
                With syf
                    For i = 2 To .Cells(Rows.Count, "A").End(3).Row + 1
                        ilktrh = .Cells(i, "B").Value2
                        sontrh = .Cells(i, "C").Value2
                        For ii = ilktrh To sontrh
                            On Error Resume Next
                            kac = 0
                            kac = WorksheetFunction.Match(ii, aralik, 0)
                            On Error GoTo 0
                            If kac > 0 Then
                                If b2 >= ilktrh Then
                                    syfRucu.Range("B" & say).Value = b2
                                Else
                                    syfRucu.Range("B" & say).Value = ilktrh
                                End If
                                syfRucu.Range("C" & say).Value = .Cells(i, "C").Value
                                syfRucu.Range("E" & say).Value = .Cells(i, "A").Value
                                say = say + 1
                                Exit For
                            End If
                        Next
                    Next
                End With
                If say > 5 Then syfRucu.Range("C" & say - 1).Value = syfRucu.Cells(2, "F").Value
            End If
        End If
    End If
    Set syf = Nothing: Set syfRucu = Nothing
End Sub

Süper, emeğinize ve sabırlınıza için çok teşekkür ederim.

[Resim: C:\fakepath\Resim_3.jpg]

Süre kısımını yaparken C5-b5+1 yapıyorum, d5 aşağıya sürüklediğimde 1 geliyor,

Şunu denedim =eğer(b5=""; c5-b5+1";" ") yaptığımda #DEĞER çıkıyor, nerede hata yapıyorum bilmiyorum. Kurmuş olduğum fikir b5 boş ise d hücresi boş olsun...
(23/11/2023, 09:05)cdenktas yazdı:
(22/11/2023, 18:38)feraz yazdı: Kodu Rücu  sayfanın kod bölümüne ekleyin.
Tarihler ve Gürevi(I1) değişince kodçalışır.


Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, ii As Long, son As Long, say As Long
    Dim syf As Worksheet, aralik(), kac As Long, syfRucu As Worksheet
    Dim b2 As Long, f2 As Long, I1 As String, ilktrh As Long, sontrh As Long
   
   
    If Not Intersect(Target, Range("B2,F2,I1")) Is Nothing Then
        Set syfRucu = ThisWorkbook.Worksheets("Rucü Yüklenici")
        b2 = Cells(2, "B").Value2: f2 = syfRucu.Cells(2, "F").Value2: I1 = syfRucu.Cells(1, "I").Value2
        Union(syfRucu.Range("B5:C" & Rows.Count), syfRucu.Range("E5:E" & Rows.Count)).Value = ""
        If Len(Trim(b2)) > 1 And Trim(b2) > 0 And Trim(f2) > 0 And Len(Trim(f2)) > 1 And Len(Trim(I1)) > 0 Then
            On Error Resume Next
            Set syf = ThisWorkbook.Worksheets(Range("I1").Value)
            On Error GoTo 0
            say = 1
            For i = syfRucu.Cells(2, "B").Value2 To (syfRucu.Cells(2, "F").Value2)
                ReDim Preserve aralik(1 To say)
                aralik(say) = i: say = say + 1
            Next
            say = 5
            If Not syf Is Nothing Then
                With syf
                    For i = 2 To .Cells(Rows.Count, "A").End(3).Row + 1
                        ilktrh = .Cells(i, "B").Value2
                        sontrh = .Cells(i, "C").Value2
                        For ii = ilktrh To sontrh
                            On Error Resume Next
                            kac = 0
                            kac = WorksheetFunction.Match(ii, aralik, 0)
                            On Error GoTo 0
                            If kac > 0 Then
                                If b2 >= ilktrh Then
                                    syfRucu.Range("B" & say).Value = b2
                                Else
                                    syfRucu.Range("B" & say).Value = ilktrh
                                End If
                                syfRucu.Range("C" & say).Value = .Cells(i, "C").Value
                                syfRucu.Range("E" & say).Value = .Cells(i, "A").Value
                                say = say + 1
                                Exit For
                            End If
                        Next
                    Next
                End With
                If say > 5 Then syfRucu.Range("C" & say - 1).Value = syfRucu.Cells(2, "F").Value
            End If
        End If
    End If
    Set syf = Nothing: Set syfRucu = Nothing
End Sub

Süper, emeğinize ve sabırlınıza için çok teşekkür ederim.

[Resim: C:\fakepath\Resim_3.jpg]

Süre kısımını yaparken C5-b5+1 yapıyorum, d5 aşağıya sürüklediğimde 1 geliyor,

Şunu denedim =eğer(b5=""; c5-b5+1";" ") yaptığımda #DEĞER çıkıyor, nerede hata yapıyorum bilmiyorum. Kurmuş olduğum fikir b5 boş ise d hücresi boş olsun...
(23/11/2023, 09:05)cdenktas yazdı:
(22/11/2023, 18:38)feraz yazdı: Kodu Rücu  sayfanın kod bölümüne ekleyin.
Tarihler ve Gürevi(I1) değişince kodçalışır.


Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, ii As Long, son As Long, say As Long
    Dim syf As Worksheet, aralik(), kac As Long, syfRucu As Worksheet
    Dim b2 As Long, f2 As Long, I1 As String, ilktrh As Long, sontrh As Long
   
   
    If Not Intersect(Target, Range("B2,F2,I1")) Is Nothing Then
        Set syfRucu = ThisWorkbook.Worksheets("Rucü Yüklenici")
        b2 = Cells(2, "B").Value2: f2 = syfRucu.Cells(2, "F").Value2: I1 = syfRucu.Cells(1, "I").Value2
        Union(syfRucu.Range("B5:C" & Rows.Count), syfRucu.Range("E5:E" & Rows.Count)).Value = ""
        If Len(Trim(b2)) > 1 And Trim(b2) > 0 And Trim(f2) > 0 And Len(Trim(f2)) > 1 And Len(Trim(I1)) > 0 Then
            On Error Resume Next
            Set syf = ThisWorkbook.Worksheets(Range("I1").Value)
            On Error GoTo 0
            say = 1
            For i = syfRucu.Cells(2, "B").Value2 To (syfRucu.Cells(2, "F").Value2)
                ReDim Preserve aralik(1 To say)
                aralik(say) = i: say = say + 1
            Next
            say = 5
            If Not syf Is Nothing Then
                With syf
                    For i = 2 To .Cells(Rows.Count, "A").End(3).Row + 1
                        ilktrh = .Cells(i, "B").Value2
                        sontrh = .Cells(i, "C").Value2
                        For ii = ilktrh To sontrh
                            On Error Resume Next
                            kac = 0
                            kac = WorksheetFunction.Match(ii, aralik, 0)
                            On Error GoTo 0
                            If kac > 0 Then
                                If b2 >= ilktrh Then
                                    syfRucu.Range("B" & say).Value = b2
                                Else
                                    syfRucu.Range("B" & say).Value = ilktrh
                                End If
                                syfRucu.Range("C" & say).Value = .Cells(i, "C").Value
                                syfRucu.Range("E" & say).Value = .Cells(i, "A").Value
                                say = say + 1
                                Exit For
                            End If
                        Next
                    Next
                End With
                If say > 5 Then syfRucu.Range("C" & say - 1).Value = syfRucu.Cells(2, "F").Value
            End If
        End If
    End If
    Set syf = Nothing: Set syfRucu = Nothing
End Sub

Süper, emeğinize ve sabırlınıza için çok teşekkür ederim.

[Resim: C:\fakepath\Resim_3.jpg]

Süre kısımını yaparken C5-b5+1 yapıyorum, d5 aşağıya sürüklediğimde 1 geliyor,

Şunu denedim =eğer(b5=""; c5-b5+1";" ") yaptığımda #DEĞER çıkıyor, nerede hata yapıyorum bilmiyorum. Kurmuş olduğum fikir b5 boş ise d hücresi boş olsun...
(23/11/2023, 09:05)cdenktas yazdı:
(22/11/2023, 18:38)feraz yazdı: Kodu Rücu  sayfanın kod bölümüne ekleyin.
Tarihler ve Gürevi(I1) değişince kodçalışır.


Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, ii As Long, son As Long, say As Long
    Dim syf As Worksheet, aralik(), kac As Long, syfRucu As Worksheet
    Dim b2 As Long, f2 As Long, I1 As String, ilktrh As Long, sontrh As Long
   
   
    If Not Intersect(Target, Range("B2,F2,I1")) Is Nothing Then
        Set syfRucu = ThisWorkbook.Worksheets("Rucü Yüklenici")
        b2 = Cells(2, "B").Value2: f2 = syfRucu.Cells(2, "F").Value2: I1 = syfRucu.Cells(1, "I").Value2
        Union(syfRucu.Range("B5:C" & Rows.Count), syfRucu.Range("E5:E" & Rows.Count)).Value = ""
        If Len(Trim(b2)) > 1 And Trim(b2) > 0 And Trim(f2) > 0 And Len(Trim(f2)) > 1 And Len(Trim(I1)) > 0 Then
            On Error Resume Next
            Set syf = ThisWorkbook.Worksheets(Range("I1").Value)
            On Error GoTo 0
            say = 1
            For i = syfRucu.Cells(2, "B").Value2 To (syfRucu.Cells(2, "F").Value2)
                ReDim Preserve aralik(1 To say)
                aralik(say) = i: say = say + 1
            Next
            say = 5
            If Not syf Is Nothing Then
                With syf
                    For i = 2 To .Cells(Rows.Count, "A").End(3).Row + 1
                        ilktrh = .Cells(i, "B").Value2
                        sontrh = .Cells(i, "C").Value2
                        For ii = ilktrh To sontrh
                            On Error Resume Next
                            kac = 0
                            kac = WorksheetFunction.Match(ii, aralik, 0)
                            On Error GoTo 0
                            If kac > 0 Then
                                If b2 >= ilktrh Then
                                    syfRucu.Range("B" & say).Value = b2
                                Else
                                    syfRucu.Range("B" & say).Value = ilktrh
                                End If
                                syfRucu.Range("C" & say).Value = .Cells(i, "C").Value
                                syfRucu.Range("E" & say).Value = .Cells(i, "A").Value
                                say = say + 1
                                Exit For
                            End If
                        Next
                    Next
                End With
                If say > 5 Then syfRucu.Range("C" & say - 1).Value = syfRucu.Cells(2, "F").Value
            End If
        End If
    End If
    Set syf = Nothing: Set syfRucu = Nothing
End Sub

Süper, emeğinize ve sabırlınıza için çok teşekkür ederim.

[Resim: C:\fakepath\Resim_3.jpg]

Süre kısımını yaparken C5-b5+1 yapıyorum, d5 aşağıya sürüklediğimde 1 geliyor,

Şunu denedim =eğer(b5=""; c5-b5+1";" ") yaptığımda #DEĞER çıkıyor, nerede hata yapıyorum bilmiyorum. Kurmuş olduğum fikir b5 boş ise d hücresi boş olsun...

[img][Resim: do.php?img=15476][/img]
Son Düzenleme: 23/11/2023, 09:09, Düzenleyen: cdenktas.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da

Bu Konudaki Yorumlar
Rucü Davaları Yüklenici Ödemeleri - Yazar: cdenktas - 07/11/2023, 09:01
RE: Rucü Davaları Yüklenici Ödemeleri - Yazar: cdenktas - 23/11/2023, 09:05
Task