günü gelince diğer sayfaya aktar

[Fuat Şirin]

arkadaşlar bir konuda yardımınıza ihtiyacım war
sayfa2 de a sütununda tarihler var

istediğim günü gelince yani bu gün olan satırları
sayfa3 e atması

yardımız için teşekkür şimdiden

 

[Orion1]

Sayfa3 teki önceki veriler silinecekmi?
Birde hangi sütunları atacak?

 

[Fuat Şirin]

evet hocam silinecek
aynı şekilde diğer sayfaya aktarılacak
yani a sütunundan itibaren

 

[Orion1]

a sütunundan hangi sütuna kadar aktarılacak?

 

[Fuat Şirin]

şu şekilde

hocam j sununa kadar

birde bu konudan hariç olarak

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
cevap = MsgBox("BU FATURA İLGİLİ KİŞİ TARAFINDAN ÖDENDİ Mİ?", vbYesNo)
If cevap = vbNo Then Exit Sub
sat = ListBox1.ListIndex
sonsat = Sheets("İŞLENEN").[a65536].End(3).Row + 1
Sheets("İŞLENEN").Range("a" & sonsat & ":j" & sonsat).Value = Sheets("ÖDENEN").Range("a" & sat + 2 & ":j" & sat + 2).Value
Sheets("ÖDENEN").Range("a" & sat + 2 & ":j" & sat + 2).Delete
MsgBox "BU FATURAYI İLGİLİ KİŞİ ÖDEMİŞTİR..."
End Sub

bu kodları kullaıyorum

istediğim çift tıklayıp diğer sayfaya geçtiğinde
işlenen satırın
G sutunda işlendi olarak yazması

 

[Orion1]

Aşağıdaki kodları bir butona atayınız.

Dim i As Long, a As Long, k As Byte
Sheets("Sayfa3").Range("A2:J65536").ClearContents
ReDim myarr(1 To 10, 1 To 1)
For i = 2 To Sheets("Sayfa2").Cells(65536, "A").End(xlUp).Row
    If Sheets("Sayfa2").Cells(i, "A").Value = Date Then
        a = a + 1
        ReDim Preserve myarr(1 To 10, 1 To a)
        For k = 1 To 10
            myarr(k, a) = Sheets("Sayfa2").Cells(i, k).Value
        Next k
    End If
Next i
Sheets("Sayfa3").Select
If a > 0 Then
    [A2].Resize(a, 10) = Application.Transpose(myarr)
End If

 

[Fuat Şirin]

hocam dosya ekte

hocam dediğiniz gibi yaptım
fakat hem önceki kaydı silmiyor
hemde ilk satırı farklı bir formata sokuyor
dosyayı ekledim
ÖDENECEK olan sayfadan
ÖDENEN olan sayfaya aktaracak..

şimdiden teşekkür

saygılar

 

[Orion1]

hocam dediğiniz gibi yaptım
fakat hem önceki kaydı silmiyor
hemde ilk satırı farklı bir formata sokuyor
dosyayı ekledim
ÖDENECEK olan sayfadan
ÖDENEN olan sayfaya aktaracak..

şimdiden teşekkür

saygılar

Ekli dosyayı inceleyiniz.:cool:
Sub aktar()
Dim i As Long, a As Long, k As Byte
Application.ScreenUpdating = False
Sheets("ÖDENEN").Range("A2:J65536").ClearContents
ReDim myarr(1 To 10, 1 To 1)
For i = 2 To Sheets("ÖDENECEK").Cells(65536, "A").End(xlUp).Row
    If Sheets("ÖDENECEK").Cells(i, "A").Value = Date Then
        a = a + 1
        ReDim Preserve myarr(1 To 10, 1 To a)
        For k = 1 To 10
            myarr(k, a) = Sheets("ÖDENECEK").Cells(i, k).Value
        Next k
    End If
Next i
Sheets("ÖDENEN").Select
If a > 0 Then
    [A2].Resize(a, 10) = Application.Transpose(myarr)
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır..!!", vbOKOnly + vbInformation, Application.UserName
End If
Application.ScreenUpdating = True
End Sub

 

[Fuat Şirin]

hocam doyanızı aldım
fakat aktarılan kaydı silmiyor
aktarılan veriyi silerse tam süper olur
saygılarımla

 

[Orion1]

hocam doyanızı aldım
fakat aktarılan kaydı silmiyor
aktarılan veriyi silerse tam süper olur
saygılarımla

Ödenen sayfasındaki verileri silip tekrardan listeleme yapıyor.
Siz ÖDENECEK sayfasındaki verileridenmi silinmesini istiyorsunuz?

 

[Fuat Şirin]

hocam kusura bakmayın netim gitti
evet hocam aktarılan verilerin silinmesini istiyorum "ödenecek" sayfasından

saygılar..

 

[Orion1]

hocam kusura bakmayın netim gitti
evet hocam aktarılan verilerin silinmesini istiyorum "ödenecek" sayfasından

saygılar..

Dosyanız hazır.

Sub aktar()
Dim i As Long, a As Long, k As Byte
Application.ScreenUpdating = False
Sheets("ÖDENEN").Range("A2:J65536").ClearContents
ReDim myarr(1 To 10, 1 To 1)
For i = Sheets("ÖDENECEK").Cells(65536, "A").End(xlUp).Row To 2 Step -1
    If Sheets("ÖDENECEK").Cells(i, "A").Value = Date Then
        a = a + 1
        ReDim Preserve myarr(1 To 10, 1 To a)
        For k = 1 To 10
            myarr(k, a) = Sheets("ÖDENECEK").Cells(i, k).Value
        Next k
        Sheets("ÖDENECEK").Range("A" & i & ":F" & i).Delete (xlUp)
    End If
Next i
Sheets("ÖDENEN").Select
If a > 0 Then
    [A2].Resize(a, 10) = Application.Transpose(myarr)
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır..!!", vbOKOnly + vbInformation, Application.UserName
End If
Application.ScreenUpdating = True
End Sub

 

[Fuat Şirin]

hocam ben mi yapamadım acaba yanlış mı anlattım anlamadım
benim istediğim günü gelince ÖDENECEK sayfasında günü gelen satırları
ÖDENEN sayfasına atması
ÖDENECEK sayfasından aktarılan verileride ÖDENECEK sayfasından silmesi

yani mantık olarak ödenen faturalar otomatik ödemede olduğundan günü gelince ödendi olarak belirtmesi

saygılar

 

[Fuat Şirin]

ÖDENEN sayfasındaki verileri silmesini istemiyorum
üstüne devam etsin

kusura bakmayın çok oluyorum ama benden kaynaklı tam anlatamadım

 

[Orion1]

hocam ben mi yapamadım acaba yanlış mı anlattım anlamadım
benim istediğim günü gelince ÖDENECEK sayfasında günü gelen satırları
ÖDENEN sayfasına atması
ÖDENECEK sayfasından aktarılan verileride ÖDENECEK sayfasından silmesi

yani mantık olarak ödenen faturalar otomatik ödemede olduğundan günü gelince ödendi olarak belirtmesi

saygılar

Ödenen sayfasındaki butona basınca Ödenecek sayfasındaki bu günkü tarihte olanları Ödenen sayfasına aktarıyor. ve ÖDENECEK sayfasından siliyor.

 

[Fuat Şirin]

evet hocam onda problem yok
ama mesela 02.03.2008 de aktarım yaptım
ama 04.03.2008 de aktardığım zaman
ÖDENEN sayfasındaki eski kayıtları siliyor
ben en son boş satırdan devam etmesini istiyorum..

 

[Orion1]

evet hocam onda problem yok
ama mesela 02.03.2008 de aktarım yaptım
ama 04.03.2008 de aktardığım zaman
ÖDENEN sayfasındaki eski kayıtları siliyor
ben en son boş satırdan devam etmesini istiyorum..

İşte bunu soruyu ilk sorduğunuzda söylemeniz gerekiyor.Soruyu açık ve net sorarsanız alamayacağınız cevap yoktur.Yoksa bizde burada uğraşıp dururuz.
Ekli dosyayı inceleyiniz.

Sub aktar()
Dim i As Long, a As Long, k As Byte
Application.ScreenUpdating = False
sat = Sheets("ÖDENEN").Cells(65536, "A").End(xlUp).Row + 1
ReDim myarr(1 To 10, 1 To 1)
For i = Sheets("ÖDENECEK").Cells(65536, "A").End(xlUp).Row To 2 Step -1
    If Sheets("ÖDENECEK").Cells(i, "A").Value = Date Then
        a = a + 1
        ReDim Preserve myarr(1 To 10, 1 To a)
        For k = 1 To 10
            myarr(k, a) = Sheets("ÖDENECEK").Cells(i, k).Value
        Next k
        Sheets("ÖDENECEK").Range("A" & i & ":F" & i).Delete (xlUp)
    End If
Next i
Sheets("ÖDENEN").Select
If a > 0 Then
    Range("A" & sat).Resize(a, 10) = Application.Transpose(myarr)
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır..!!", vbOKOnly + vbInformation, Application.UserName
End If
Application.ScreenUpdating = True
End Sub

 

[Fuat Şirin]

hocam çok teşekkür
gerçekten sabrınızdan dolayı teşekkür ederim
ÖDENEN ile ÖDENECEK sayfalarını açıklamakta zorlandım
yardımınız için çok teşekkür güzel oldu ama....

saygılar....

 

[drykcktl]

İşte bunu soruyu ilk sorduğunuzda söylemeniz gerekiyor.Soruyu açık ve net sorarsanız alamayacağınız cevap yoktur.Yoksa bizde burada uğraşıp dururuz.
Ekli dosyayı inceleyiniz.

Sub aktar()
Dim i As Long, a As Long, k As Byte
Application.ScreenUpdating = False
sat = Sheets("ÖDENEN").Cells(65536, "A").End(xlUp).Row + 1
ReDim myarr(1 To 10, 1 To 1)
For i = Sheets("ÖDENECEK").Cells(65536, "A").End(xlUp).Row To 2 Step -1
    If Sheets("ÖDENECEK").Cells(i, "A").Value = Date Then
        a = a + 1
        ReDim Preserve myarr(1 To 10, 1 To a)
        For k = 1 To 10
            myarr(k, a) = Sheets("ÖDENECEK").Cells(i, k).Value
        Next k
        Sheets("ÖDENECEK").Range("A" & i & ":F" & i).Delete (xlUp)
    End If
Next i
Sheets("ÖDENEN").Select
If a > 0 Then
    Range("A" & sat).Resize(a, 10) = Application.Transpose(myarr)
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır..!!", vbOKOnly + vbInformation, Application.UserName
End If
Application.ScreenUpdating = True
End Sub

link güncellenebilirmi

 

[asilme]

KİTAP 59 dosyası banada gerekli nerede niye alamadım