Soru Veri sayfasından ilgili sayfalara bilgi aktarma

[reosman]

Veri sayfasına web'den kopyala yapıştır yapıyorum.
Veri sayfasında boyalı olan

B sütununda MH verileri
D sütununda İLÇE verileri
E sütununda SİCİL verileri
G sütununda ÜNVANI verileri bulunmaktadır.

Talep ettiğim; Veri sayfasındaki bu verilen,

Yüreğir-2, Yüreğir-4, Sarıçam-2, Sarıçam-4 sayfalarıma

B sütunundaki MH ve D sütunundaki İLÇE verilerine bakarak TÜM SATIR

Örneğin; MH verisi 2, İLÇE verisi YÜREĞİR - Yüreğir-2 sayfasının
en altına boşluklarıda kaldırarak kopyalanacak, E sütunundaki SİCİL numarasına
göre aynı kayıt varsa uyarı vererek kopyalama yapmayacak.

Örneğin; MH verisi 4, İLÇE verisi YÜREĞİR - Yüreğir-4 sayfasının
en altına boşluklarıda kaldırarak kopyalanacak, E sütunundaki SİCİL numarasına
göre aynı kayıt varsa uyarı vererek kopyalama yapmayacak.

Örneğin; MH verisi 2, İLÇE verisi SARIÇAM - Sarıçam-2 sayfasının
en altına boşluklarıda kaldırarak kopyalanacak, E sütunundaki SİCİL numarasına
göre aynı kayıt varsa uyarı vererek kopyalama yapmayacak.

Örneğin; MH verisi 4, İLÇE verisi SARIÇAM - Sarıçam-4 sayfasının
en altına boşluklarıda kaldırarak kopyalanacak, E sütunundaki SİCİL numarasına
göre aynı kayıt varsa uyarı vererek kopyalama yapmayacak.


Vereceğiniz emekleriniz için şimdiden çok çok teşekkür ederim.

 

[reosman]

Veri sayfasında örnek hatası vardı tekrar yolluyorum.

 

[reosman]

Hocalarım yardımlarınızı rica ediyorum.

 

[Ömer]

Merhaba,

Modul3'e ekleyiniz.

Sub aktar()
    
    Dim i As Long, syf As String, c As Range, sat As Long, mesaj As String
    
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Sheets("Veri").Select
    
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        syf = Cells(i, "D") & "-" & Cells(i, "B")
        If varmi(syf) Then
            With Sheets(syf)
                Set c = .[D:D].Find(Cells(i, "E"), , xlValues, xlWhole)
                If c Is Nothing Then
                    sat = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                    .Cells(sat, "A") = sat - 1
                    .Cells(sat, "B") = Cells(i, "B")
                    .Cells(sat, "C") = Cells(i, "D")
                    .Cells(sat, "D") = Cells(i, "E")
                    .Cells(sat, "E") = Cells(i, "G")
                Else
                    mesaj = mesaj & vbLf & Cells(i, "E")
                End If
            End With
        End If
    Next i
    
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    If mesaj <> "" Then
        MsgBox "Aşağıda Mükerrer Olan Sicillerin Dışındakiler Aktarıldı." & vbLf & "Aktarılmayanlar:" & vbLf & mesaj, vbInformation
    Else
        MsgBox "Aktarım bitti.", vbInformation
    End If
       
End Sub

 

[reosman]

Hocam çok çok çok teşekkür ederim RABBİM ne muradınız varsa versin yoldayım eve geçip deneyip bilgi vereceğim

 

[reosman]

Hocam çok teşekkürler tam istediğim gibi olmuş, Harikasınız

 

[reosman]

Ömer hocam merhaba,

Yardımınız için öncelikle çok çok teşekkür ederim.

Hocam yukarıdaki kodlarda şu şekilde bir revize gerekiyor.


B Sütunu (Mh Kodu) "1" ve "2"
D Sütunu (İlçe) "Yüreğir" olanlar "Yüreğir-2" sayfasına

B Sütunu (Mh Kodu) "3" ve "4"
D Sütunu (İlçe) "Yüreğir" olanlar "Yüreğir-4" sayfasına

B Sütunu (Mh Kodu) "1" ve "2"
D Sütunu (İlçe) "Sarıçam" olanlar "Sarıçam-2" sayfasına

B Sütunu (Mh Kodu) "3" ve "4"
D Sütunu (İlçe) "Sarıçam" olanlar "Sarıçam-4" sayfasına

aktarılması şeklinde kodları revize edebilirmiyiz. Saygılarımla.

 

[Ömer]

Merhaba,

Deneme yapmadım.

Kodlardaki;

syf = Cells(i, "D") & "-" & Cells(i, "B")

yukarıdaki satır yerine aşağıdaki satırı yazarak deneyiniz.

syf = Cells(i, "D") & "-" & (Cells(i, "B") Mod 2) + Cells(i, "B")

 

[reosman]

Hocam ellerinize sağlık. Allah razı olsun. Bilgi vereceğim. Saygılarımla.