2 farklı sayfaya veri aktarma

m.ensar · 25 Ekim 2023

Hocalarım ek çalışmada sayfalar arası veri aktarma var. istediğim ONAY sayfasına aktar dediğimde aynı satırı ÖDEME sayfasına aktarılması yardımcı olur musunuz?
Ek çalışmayada açıklama yazdım

m.ensar · 26 Ekim 2023

Bu konuda yardımcı olabilecek hocalarım aynı listede GÜNCEL sayfasında Yknlk - Mahalle adı - başvuru şekli - Red sonlanma nedenleri sütunlarında veri doğrulama var. VERİLER sayfasından aldığımız bu doğrulamaları Makro ile yapabilir miyiz? Yardımcı olur musunuz?

Muzaffer Ali · 26 Ekim 2023

Merhaba.
Private Sub ListBox1_Click() kodlarını silin yerine aşağıdakileri kopyalayın.

Kod:

Private Sub ListBox1_Click()
    Dim n As String
    a = ActiveCell.Row
    ActiveCell = ListBox1.Value
    ListBox1.Visible = False
    ActiveCell.Offset(0, 1).Select
    If WorksheetFunction.CountBlank(Range("A" & a & ":T" & a)) > 0 Then
        MsgBox "Lütfen tüm alanları doldurunuz!"
        Set c = Range("A" & a & ":T" & a).Find("")
        If Not c Is Nothing Then c.Select
    Else
        For i = 1 To Sheets.Count
            If Sheets(i).Name = Cells(a, "S") Then
                yeni = Sheets(i).Cells(Rows.Count, "A").End(3).Row + 1
                Range("A" & a & ":T" & a).Copy Sheets(i).Cells(yeni, "A")
                If Cells(a, "S") = "ONAY" Then
                    yeni = Sheets("ÖDEME").Cells(Rows.Count, "A").End(3).Row + 1
                    Range("A" & a & ":T" & a).Copy Sheets("ÖDEME").Cells(yeni, "A")
                    n = " ve ÖDEME "
                End If
            End If
        Next
    End If
    MsgBox a - 1 & ". veri " & Cells(a, "S") & n & " sayfasına aktarıldı.", vbInformation
    If Cells(a, "S") <> "ONAY" Then
        ActiveCell.EntireRow.Delete
        Cells(a + 1, "U").Select
    End If
End Sub

m.ensar · 27 Ekim 2023

Muzaffer hocam çok teşekkür ediyorum emeğinize sağlık

m.ensar · 2 Kasım 2023

Private Sub ListBox1_Click()
Dim n As String
a = ActiveCell.Row
ActiveCell = ListBox1.Value
ListBox1.Visible = False
ActiveCell.Offset(0, 1).Select
If WorksheetFunction.CountBlank(Range("A" & a & ":U" & a)) > 0 Then
MsgBox "Lütfen tüm alanları doldurunuz!"
Set c = Range("A" & a & ":U" & a).Find("")
If Not c Is Nothing Then c.Select
Else
For i = 1 To Sheets.Count
If Sheets(i).Name = Cells(a, "T") Then
yeni = Sheets(i).Cells(Rows.Count, "A").End(3).Row + 1
Range("A" & a & ":U" & a).Copy Sheets(i).Cells(yeni, "A")
If Cells(a, "T") = "SONLANDI" Then
yeni = Sheets("ÖDEME").Cells(Rows.Count, "A").End(3).Row + 1
Range("A" & a & ":U" & a).Copy Sheets("ÖDEME").Cells(yeni, "A")
n = " ve ÖDEME "
End If
End If
Next
End If
MsgBox a - 1 & ". veri " & Cells(a, "T") & n & " sayfasına aktarıldı.", vbInformation
If Cells(a, "S") <> "ONAY" Then
ActiveCell.EntireRow.Delete
Cells(a + 1, "U").Select
End If
End Sub

Bu kodlar Muzaffer Ali hocam tarafından 2 sayfaya veri aktarılacak şekilde revize edildi. GÜNCEL sayfasında Onay sütununda tarih yerine X olan satırların ÖDEME sayfasına aktarılmasını önleyebilir miyiz? Onay sütununda tarih yoksa kişi ödeme alamayacak demektir. Az önce de aynı konuyu açmıştım Listede kişi bilgilerini açık unuttuğumdan dolayı kaldırdım

Muzaffer Ali · 2 Kasım 2023

Merhaba.

Kodları aşağıdaki ile değiştirin.

Kod:

Private Sub ListBox1_Click()
    Dim n As String
    a = ActiveCell.Row
    ActiveCell = ListBox1.Value
    ListBox1.Visible = False
    ActiveCell.Offset(0, 1).Select
    If WorksheetFunction.CountBlank(Range("A" & a & ":U" & a)) > 0 Then
        MsgBox "Lütfen tüm alanları doldurunuz!"
        Set c = Range("A" & a & ":U" & a).Find("")
        If Not c Is Nothing Then c.Select
    Else
        For i = 1 To Sheets.Count
            If Sheets(i).Name = Cells(a, "T") Then
                yeni = Sheets(i).Cells(Rows.Count, "A").End(3).Row + 1
                Range("A" & a & ":U" & a).Copy Sheets(i).Cells(yeni, "A")
                If Cells(a, "T") = "SONLANDI" And IsDate(Cells(a, "N")) Then
                    yeni = Sheets("ÖDEME").Cells(Rows.Count, "A").End(3).Row + 1
                    Range("A" & a & ":U" & a).Copy Sheets("ÖDEME").Cells(yeni, "A")
                    n = " ve ÖDEME "
                End If
            End If
        Next
    End If
    MsgBox a - 1 & ". veri " & Cells(a, "T") & n & " sayfasına aktarıldı.", vbInformation
    If Cells(a, "S") <> "ONAY" Then
        ActiveCell.EntireRow.Delete
        Cells(a + 1, "U").Select
    End If
End Sub

m.ensar · 2 Kasım 2023

Muzaffer Hocam harikasınız çok teşekkür ediyorum

m.ensar · 7 Kasım 2023

hocalarım yukarıdaki kodlarda ve benzeri kodlarda resimdeki uyarıyı veriyor tamam dediğimizde yada x den kapattığımızda veriler aktarılmıştır diyor ancak ilgili sayfaya aktarmadığı gibi satırıda komple aktarılmış gibi siliyor. Satırda boş hücre var ise bu uyarıyı verdikten sonra aktarma yapmamasını satır aktarılmıştır uyarısı yerinede boş hücreleri doldurduktan sonra tekrar deneyiniz vb. bir uyarı gelmesini sağlayabilir miyiz? örnek çalışma 5. mesajda var

Muzaffer Ali · 8 Kasım 2023

Merhaba.

Kod:

Private Sub ListBox1_Click()
    Dim n As String
    a = ActiveCell.Row
    ActiveCell = ListBox1.Value
    ListBox1.Visible = False
    ActiveCell.Offset(0, 1).Select
    If WorksheetFunction.CountBlank(Range("A" & a & ":U" & a)) > 0 Then
        MsgBox "Lütfen tüm alanları doldurunuz!"
        Set c = Range("A" & a & ":U" & a).Find("")
        If Not c Is Nothing Then c.Select
        exit sub
    Else
        For i = 1 To Sheets.Count
            If Sheets(i).Name = Cells(a, "T") Then
                yeni = Sheets(i).Cells(Rows.Count, "A").End(3).Row + 1
                Range("A" & a & ":U" & a).Copy Sheets(i).Cells(yeni, "A")
                If Cells(a, "T") = "SONLANDI" And IsDate(Cells(a, "N")) Then
                    yeni = Sheets("ÖDEME").Cells(Rows.Count, "A").End(3).Row + 1
                    Range("A" & a & ":U" & a).Copy Sheets("ÖDEME").Cells(yeni, "A")
                    n = " ve ÖDEME "
                End If
            End If
        Next
    End If
    MsgBox a - 1 & ". veri " & Cells(a, "T") & n & " sayfasına aktarıldı.", vbInformation
    If Cells(a, "S") <> "ONAY" Then
        ActiveCell.EntireRow.Delete
        Cells(a + 1, "U").Select
    End If
End Sub

m.ensar · 8 Kasım 2023

Dim n As String tek fark bunu bulabildim eğer gözden kaçırmadı isem, gece boyu uğraştım çeşitli yerlere değişik kodlar yazarak ama yapamamıştım. Gerçekten bilgi çok değerli çok teşekkür ediyorum. bu çalışmayı uzun zamandır ihtiyaç hasıl oldukça sizlerin sayesinde revize ediyorum ufak tefek eklentilerim varsa da Korhan hocam, İdris Hocam Ömer hocam Yusuf Hocam Necdet Hocam daha birçok hocamın ve sizin emeğiniz çok. Çok teşekkür ederim

m.ensar · 8 Kasım 2023

Exit Sub bu eksikmiş hocam Dim n As String burası değilmiş ))) teşekkür ediyorum

m.ensar · 22 Ekim 2024

Muzaffer Ali' Alıntı:

Merhaba.
Private Sub ListBox1_Click() kodlarını silin yerine aşağıdakileri kopyalayın.

Kod:

Private Sub ListBox1_Click()
    Dim n As String
    a = ActiveCell.Row
    ActiveCell = ListBox1.Value
    ListBox1.Visible = False
    ActiveCell.Offset(0, 1).Select
    If WorksheetFunction.CountBlank(Range("A" & a & ":T" & a)) > 0 Then
        MsgBox "Lütfen tüm alanları doldurunuz!"
        Set c = Range("A" & a & ":T" & a).Find("")
        If Not c Is Nothing Then c.Select
    Else
        For i = 1 To Sheets.Count
            If Sheets(i).Name = Cells(a, "S") Then
                yeni = Sheets(i).Cells(Rows.Count, "A").End(3).Row + 1
                Range("A" & a & ":T" & a).Copy Sheets(i).Cells(yeni, "A")
                If Cells(a, "S") = "ONAY" Then
                    yeni = Sheets("ÖDEME").Cells(Rows.Count, "A").End(3).Row + 1
                    Range("A" & a & ":T" & a).Copy Sheets("ÖDEME").Cells(yeni, "A")
                    n = " ve ÖDEME "
                End If
            End If
        Next
    End If
    MsgBox a - 1 & ". veri " & Cells(a, "S") & n & " sayfasına aktarıldı.", vbInformation
    If Cells(a, "S") <> "ONAY" Then
        ActiveCell.EntireRow.Delete
        Cells(a + 1, "U").Select
    End If
End Sub

Merhaba üstadlar bu koda nasıl bir ek yapılmalı yada revize edilmeliki ONAY sayfasına aktar dediğim de ÖDEME sayfasına aktarma yaparken RET sayfasına aktar dediğimde de ÖDEME sayfasına aktarma yapabilsin. Yani ONAY Sayfasından başka sayfayı seçtiğimde seçtiğim sayfa ile birlikte ÖDEME sayfasına da aktarabilsin

pitchoute · 22 Ekim 2024

Kodunuzu şu şekilde revize edip sonucu paylaşabilir misiniz;

Kod:

Else
    For i = 1 To Sheets.Count
        If Sheets(i).Name = Cells(a, "S") Then
            yeni = Sheets(i).Cells(Rows.Count, "A").End(3).Row + 1
            Range("A" & a & ":T" & a).Copy Sheets(i).Cells(yeni, "A")
            
            If Cells(a, "S") = "ONAY" Or Cells(a, "S") = "RET" Then
                yeni = Sheets("ÖDEME").Cells(Rows.Count, "A").End(3).Row + 1
                Range("A" & a & ":T" & a).Copy Sheets("ÖDEME").Cells(yeni, "A")
                n = " ve ÖDEME "
            End If
        End If
    Next
End If

Kod:

If Cells(a, "S") <> "ONAY" And Cells(a, "S") <> "RET" Then
    ActiveCell.EntireRow.Delete
    Cells(a + 1, "U").Select
End If

m.ensar · 23 Ekim 2024

Hayırlı sabhalar
If Cells(a, "S") = "ONAY" Or Cells(a, "S") = "RET" Then
burada ki Or kelimesi hiç aklıma gelmedi üstadım emeğine sağlık çok teşekkür ederim

pitchoute · 23 Ekim 2024

Hayırlı sabahlar, rica ederim hocam iyi çalışmalar

2 farklı sayfaya veri aktarma

m.ensar

Ekli dosyalar

m.ensar

Muzaffer Ali

Destek Ekibi

m.ensar

m.ensar

Ekli dosyalar

Muzaffer Ali

Destek Ekibi

m.ensar

m.ensar

Muzaffer Ali

Destek Ekibi

m.ensar

m.ensar

m.ensar

pitchoute

m.ensar

pitchoute