Soru Sayfadaki kayıtlı veriyi hücre değişiminde başka sayfaya aktarmak.

[reosman]

Sorum şu;

Yüreğir-2 sayfasının C (İLÇE) sütununda bulunan kayıtlarından
herhangibirinin ilçesi (C Sütunu) Sarıçam olarak değiştirildinde bu satırın
sıra numarasını almadan Sarıçam-2 sayfasına aktarılmasını,

Yüreğir-4 sayfasının C (İLÇE) sütununda bulunan kayıtlarından
herhangibirinin ilçesi (C Sütunu) Sarıçam olarak değiştirildinde bu satırın
sıra numarasını almadan Sarıçam-4 sayfasına aktarılmasını nasıl sağlayabiliriz.

Vereceğiniz bilgiler işin şimdiden teşekkür ederim. Saygılarımla.

 

[reosman]

Üstadlar Yardımlarınızı rica ediyorum

 

[reosman]

Üstadlar bir el atın lütfen

 

[Ziynettin]

Hücreye yazıldığında olacak ise basit yazılmış kod.

Kodu Yüreğir-2 sayfası Change olayında bu şekilde deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

    TextBox2.Text = WorksheetFunction.CountA(Range("F2:F1047576"))
    
    Dim sh As Worksheet, son As Long, sat As Long
    If Target.Column = 3 Then
        Set sh = Sheets("Sarıçam-2")
        If Target.Text = "Sarıçam" Then
            son = sh.Cells(Rows.Count, 3).End(3).Row + 1
            sat = Target.Row
            sh.Cells(son, 1) = son - 1
            Cells(sat, 2).Resize(, 4).Copy sh.Cells(son, 2)
            'Cells(sat, 1).Resize(, 5).ClearContents
        End If
    End If
    
End Sub

 

[reosman]

Hocam Allah razı olsun. Çok teşekkür ederim. Son olarak ilçe hücresine çift tıklama veya mesajla belirtme gibi bir alternatif olabilirmi. Saygılarımla.

 

[Ziynettin]

Yüreğir-2 sayfası kod alnına.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Alan As Range
    Dim yeni As Integer
    Dim A, Son As Integer
    Set Alan = Range("F2:F1045876")
    If Not Intersect(Target, Alan) Is Nothing Then
        Cancel = True
        If IsEmpty(Target) Then
            Target = "İZ OLDU"
            Son = Sheets("İz").Cells(Rows.Count, "B").End(3).Row
            A = Target.Row
            If WorksheetFunction.CountIfs(Sheets("İz").Range("B1:B" & Son), Cells(A, "B"), Sheets("İz").Range("C1:C" & Son), Cells(A, "C"), _
                Sheets("İz").Range("D1:D" & Son), Cells(A, "D"), Sheets("İz").Range("E1:E" & Son), Cells(A, "E")) = 0 Then
                Range("B" & A & ":E" & A).Copy Sheets("İz").Cells(Son + 1, "B")
                Sheets("İz").Cells(Son + 1, "A") = Son
            Else
                MsgBox "İz Kayıtlarında Aynı Kayıt Var!!", 16, "Dikkat"
            End If
        Else
            Target.ClearContents
        End If
    End If
    
   '*****************************************
  
    If Target.Column = 3 And Target.Count = 1 And Target.Row > 1 Then
        Dim sat As Long, ack As String, satir As Long, sh As Worksheet
        Cancel = True
        sat = Target.Row
        ack = Range("B1") & vbTab & ":  " & Range("B" & sat) & vbLf & _
              Range("C1") & vbTab & ":  " & Range("C" & sat) & vbLf & _
              Range("D1") & vbTab & ":  " & Range("D" & sat) & vbLf & _
              Range("E1") & vbTab & ":  " & Range("E" & sat) & vbLf & _
              Range("F1") & vbTab & ":  " & Range("F" & sat) & vbLf & vbLf & _
              "--------------------------------------------" & vbLf & vbLf & _
              "Yukarıdaki bigiler SARIÇAM-2 sayfasına yazdırılsın mı?"
    
        If MsgBox(ack, vbYesNo) = vbYes Then
            Set sh = Sheets("Sarıçam-2")
            satir = sh.Cells(Rows.Count, 3).End(3).Row + 1
            sh.Cells(satir, 1) = satir - 1
            Cells(sat, 2).Resize(, 4).Copy sh.Cells(satir, 2)
            sh.Cells(satir, 3) = "Sarıçam"
            'Cells(sat, 1).Resize(, 5).ClearContents
            MsgBox "Verileriniz yadırıldı.", vbInformation
        Else
            MsgBox "İşlem iptal edilidi.", vbCritical
        End If
    End If
    
End Sub

 

[reosman]

Eyvallah hocam. Allah Razı olsun. Çok çok teşekkür ederim.

 

[reosman]

Özür dilerim hocam süper olmuş elinize sağlık.

 

[Ziynettin]

Dosyanız. ekte.