Rakamların karşılıklarını diğer sayfaya aktarma Düşeyara 2.değer

[reckly]

Rakamların karşılıklarını diğer sayfaya aktarma Düşeyara 2.değer

Sayın Arkadaşlar,

Sorunum şu ki, bir listem var bayağı uzun. bu listede aynı rakamlar birden çok bulunabilmekte. Amacım bu rakamların yanlarındaki değerleri diğer sayfaya aktarmak ancak aynı rakamın birden çok olması durumunda diğer sayfada bunları sütun boyunca yan yana aktarmak istiyorum. Ekte daha rahat anlayabilirsiniz.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

Sub aktar()
Set s1 = Sheets("sheet1")
Set s2 = Sheets("sheet2")
For a = 1 To s1.[a65536].End(3).Row
If WorksheetFunction.CountIf(s1.Range("a1:a" & a), s1.Cells(a, "a")) = 1 Then
c = c + 1
s2.Cells(c, "a") = s1.Cells(a, "a")
s2.Cells(c, 256).End(xlToLeft).Next = s1.Cells(a, "b")
Else
sat = WorksheetFunction.Match(s1.Cells(a, "a"), s2.[a:a], 0)
s2.Cells(sat, 256).End(xlToLeft).Next = s1.Cells(a, "b")
End If
Next
End Sub

 

[reckly]

Aşağıdaki kodu deneyin.

Sub aktar()
Set s1 = Sheets("sheet1")
Set s2 = Sheets("sheet2")
For a = 1 To s1.[a65536].End(3).Row
If WorksheetFunction.CountIf(s1.Range("a1:a" & a), s1.Cells(a, "a")) = 1 Then
c = c + 1
s2.Cells(c, "a") = s1.Cells(a, "a")
s2.Cells(c, 256).End(xlToLeft).Next = s1.Cells(a, "b")
Else
sat = WorksheetFunction.Match(s1.Cells(a, "a"), s2.[a:a], 0)
s2.Cells(sat, 256).End(xlToLeft).Next = s1.Cells(a, "b")
End If
Next
End Sub

Çok teşekkür ederim leventm. Bende bu sorunumu formüllerle çözmeye çalışıyordum. Düşeyara ile yol katettim ama sanırım beceremiycem.
Tekrar teşekkürler.
İyi çalışmalar.

 

[Ali]

. Bende bu sorunumu formüllerle çözmeye çalışıyordum. Düşeyara ile yol katettim ama sanırım beceremiycem.

Formüller ile yapılmış örnek ektedir.

 

[reckly]

Teşekkürler

Formüller ile yapılmış örnek ektedir.

Sayın Ali,

Bu çözüm içinde çok teşekkür ederim. Ufkumu açtı. Ellerinize sağlık.

 

[asd_demir]

usta sağol ellerine sağlık