Teke düşürerek veri aktarmak

[kontto]

Arkadaşlar elim de daha önceden bu siteden arkadaşların vermiş olduğu bir kod var sizden istediğim teke düşürerek aktarma işleminde B sütununda ki verileri de teke düşürerek aktarması, örnek dosya gönderiyorum, yardımlarınız için şimdiden teşekkür ediyorum.

Private Sub Worksheet_Activate()
Dim i As Integer, son As Integer, sat As Integer

With Sheets("Veri")

son = .Range("C" & Rows.Count).End(3).Row
Range("A2:B" & Rows.Count).ClearContents
sat = 2
For i = 2 To son
If WorksheetFunction.CountIf(.Range("C2:C" & i), .Cells(i, 3)) = 1 Then
Cells(sat, "A") = .Cells(i, 3)
Cells(sat, "B") = WorksheetFunction.CountIf(.Range("C2:C" & son), .Cells(i, "C"))
sat = sat + 1
End If
Next i
End With
End Sub

 

[kontto]

Üstadlardan yardım bekliyorum.

 

[cenk e.]

Merhaba, şu kodu dener misiniz.

Private Sub Worksheet_Activate()
 Dim i As Integer, son As Integer, sat As Integer
 
 With Sheets("Veri")
 
        son = .Range("C" & Rows.Count).End(3).Row
        Range("A2:C" & Rows.Count).ClearContents
            sat = 2
    For i = 2 To son
        If WorksheetFunction.CountIf(.Range("C2:C" & i), .Cells(i, 3)) = 1 Then
         [COLOR="Red"]   Cells(sat, "A") = .Cells(i, 3)
            Cells(sat, "B") = .Cells(i, 2)
            Cells(sat, "C") = WorksheetFunction.CountIf(.Range("C2:C" & son), .Cells(i, "C"))[/COLOR]
            sat = sat + 1
        End If
    Next i
 End With
End Sub

 

[kontto]

Cenk bey çok teşekkür ederim. Aktarıyor Ancak aktardığı gibi kalıyor. Yani C sütununda ki veriler gibi kendini yenilemiyor.

 

[cenk e.]

Merhaba, o da dinamik olarak çalışıyor ama ben yanlış anladım galiba. Yeni eklemeler yapıp sayfa 2 ye tıklayınca değişiklikleri görüyorum.

 

[cenk e.]

İş görmedi galiba, bilen bir kişi yardımcı olursa daha iyi olur.

 

[Orion1]

dosyanız ektedir.

Private Sub Worksheet_Activate()
 Dim i As Integer, son As Integer, sat As Integer, sat2 As Long
 With Sheets("Veri")
  
        Range("A2:D" & Rows.Count).ClearContents
            sat = 2
            sat2 = 2
    For i = 2 To 40
        If WorksheetFunction.CountIf(.Range("C2:C" & i), .Cells(i, 3)) = 1 Then
            Cells(sat, "A") = .Cells(i, 3)
            Cells(sat, "B") = WorksheetFunction.CountIf(.Range("C2:C40"), .Cells(i, "C"))
            sat = sat + 1
        End If
        If WorksheetFunction.CountIf(.Range("B2:B" & i), .Cells(i, 2)) = 1 Then
            Cells(sat2, "C") = .Cells(i, 2)
            Cells(sat2, "D") = WorksheetFunction.CountIf(.Range("B2:B40"), .Cells(i, "B"))
            sat2 = sat2 + 1
        End If
    Next i
 End With
End Sub

 

[kontto]

cenk bey ve Orion bey teşekkür ederim her ikisi de işime yaradı. Ancak veri aktarmada sütunların belli bir noktasına kadar aktarma yaptıramaz mıyız. Örnek olarak aktarma işlemi A2 : D40 arasına yapsın daha aşağıya gitmesin. Birde bu şekilde yardım ederseniz minnettar olurum. Umarım sizi yormuyorumdur.

 

[mancubus]

son = 40 şeklinde deneyin.

 

[Orion1]

cenk bey ve Orion bey teşekkür ederim her ikisi de işime yaradı. Ancak veri aktarmada sütunların belli bir noktasına kadar aktarma yaptıramaz mıyız. Örnek olarak aktarma işlemi A2 : D40 arasına yapsın daha aşağıya gitmesin. Birde bu şekilde yardım ederseniz minnettar olurum. Umarım sizi yormuyorumdur.

7 nolu mesajdaki dosyayı güncelledim.Oradan indirebilirsiniz.