Veri Aktar

[Ahmet Sami]

Arkadaşlar, E8 'e kapı nolardan birini girince ARŞİV deki karşılıklarını alsın ve otomatik olarak TEBLİG deki göründüğü gibi oraya atsın. Ancak TEBLİG'e atarken de TARİH 'i yani E9 'da bulunan noktalı tarihi, TEBLİG de bulunan Y sütununa diğer dolu olan sütunların karşısına atsın yani doldursun istiyorum. TEBLİG de hücre şekilleri ile birlikte bozulmadan aktarım ne kadar ise o kadar aktarsın. Yani Kapı Görevlileri 3 kişide olabilir 40 kişide olabilir.
Yardımlarınız için şimdiden teşekkür ederim.

 

[Necdet]

Merhaba,
1. ANASAYFA'da tarih dediğiniz değer noktalı olarak mı duracak?
2. TEBLİĞ sayfasında basit 5 sütun için neden bir sürü hücreleri birleştirdiniz? Excele ızdırap mı çektirmek istiyorsunuz?

Aşağıdaki kodları ANASAYFA'nın kod bölümüne kopyalayıp deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [E8]) Is Nothing Or [E8] = "" Then Exit Sub
    
    Dim i   As Long, _
        c   As Range, _
        Adr As String, _
        ShT As Worksheet, _
        ShA As Worksheet
    
    Set ShA = Sheets("ARŞİV")
    Set ShT = Sheets("TEBLİG")
    
    i = ShT.Cells(Rows.Count, "A").End(3).Row
    If i < 6 Then i = 6
    ShT.Range("A6:E" & i).ClearContents
    
    i = 5
    
    With ShA.Range("D:D")
        Set c = .Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                i = i + 1
                ShT.Cells(i, "B") = ShA.Cells(c.Row, "A")
                ShT.Cells(i, "C") = ShA.Cells(c.Row, "B")
                ShT.Cells(i, "D") = ShA.Cells(c.Row, "C")
                ShT.Cells(i, "E") = Range("E9")
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
    
    ShT.Range("A6") = 1
    ShT.Range("A6:A" & i).DataSeries Step:=1
    
End Sub

 

[Ahmet Sami]

Necdet bey teşekkür ederim. Ancak Veriyi alırken sürekli alt alta ekleyip devam ediyor oysaki silip yerine yazması gerekiyordu. Yani K2 yazdığım zaman öncekileri silip K2 olanları aktarması gerekiyor.
Ayrıca tarih noktalı olarak yer alacak inşallah.

 

[Necdet]

Sadece Kodları yeniledim, dener misiniz?
Dosya eski hali ile duruyor.

 

[Ahmet Sami]

Elinize emeğinize sağlık çok teşekkür ederim sağolun.

 

[Necdet]

Rica ederim, güle güle kullanınız.