• DİKKAT

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

2 farklı sayfaya veri aktarma

  • Konbuyu başlatan Konbuyu başlatan m.ensar
  • Başlangıç tarihi Başlangıç tarihi
M

m.ensar

Katılım
5 Nisan 2016
Mesajlar
445
Excel Vers. ve Dili
office 2016 Türkçe
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
 

Ekli dosyalar

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?
 
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
 
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
 

Ekli dosyalar

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
 
247570
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
 
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
 
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
 
Exit Sub bu eksikmiş hocam Dim n As String burası değilmiş ))) teşekkür ediyorum
 
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
Genişletmek için tıkla ...
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
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst