Çoklu mükerer giriş

[teonet]

Merhaba,
Örnekte bulunan dosyada, a sayfasında bulunan a,b,c sütunlarını eşleştirerek mükerrer olmayacak şekilde b sayfasına yazmasını istiyorum. Bu işlemi yenilenleri kaldır butonu ile yapabiliyorum fakat bana formülle otomatik olarak gelmesi gerekiyor.

konu hakkında desteklerinizi bekliyorum

saygılarımla

 

[halit3]

Makrolu çözümü

kod:

Sub aktar()

ZBasla = TimeValue(Now)
zaman = Timer

Set s1 = Sheets("a") ' veri sayfası
Set s2 = Sheets("b") 'aktarılan sayfa

s2.Range("a2:f" & Rows.Count).Clear
son1 = s1.Cells(Rows.Count, "c").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 2 To son1
ara1(j) = s1.Cells(j, "a") & s1.Cells(j, "b") & s1.Cells(j, "c")
ara2(j) = 1
Next j

sat1 = 1

For r = 1 To son1
aranan1 = ara1(r)

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
ara2(i) = 0
End If
Next i

s2.Cells(sat1, 1).Value = s1.Cells(r, 1).Value
s2.Cells(sat1, 2).Value = s1.Cells(r, 2).Value
s2.Cells(sat1, 3).Value = s1.Cells(r, 3).Value
sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

 

[teonet]

Merhaba,
hızlı ve etkili çözüm için teşekkür ederim. Bir sorum daha olacak. A sayfasında (aranan) a,b,c sütunlarında veri arıyoruz. Gerçek dosyamda bu veriler E,F,I sütunlarında yer alıyor.(hatta 3. satırdan başlıyor). inceledim fakat bu şekilde uyarla yamadım. Bunu nasıl yapabileceğimi söyleyebilir misiniz?

bunun dışında çok güzel çalışıyor. elinize sağlık

 

[halit3]

Alıntı yazımı okuyunuz eklediğiniz dosya bire bir aynı olursa (sanal verilerle) işlem yapmak daha kolay olur yoksa yazılan kodu bir kez daha yazmak gerekiyor.


kod:

Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer

Set s1 = Sheets("a") ' veri sayfası
Set s2 = Sheets("b") 'aktarılan sayfa

bas_sat = 3 'taranan sayfanın baslangıç satırı
sat1 = 1 'aktarılan başlangıç satırı

s2.Range("a" & sat1 & ":c" & Rows.Count).Clear
son1 = s1.Cells(Rows.Count, "e").End(3).Row
ReDim ara1(son1): ReDim ara2(son1):

For j = bas_sat To son1
ara1(j) = s1.Cells(j, "e") & s1.Cells(j, "f") & s1.Cells(j, "ı")
ara2(j) = 1
Next j

For r = bas_sat To son1
aranan1 = ara1(r)

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
ara2(i) = 0
End If
Next i

s2.Cells(sat1, "a").Value = s1.Cells(r, "e").Value
s2.Cells(sat1, "b").Value = s1.Cells(r, "f").Value
s2.Cells(sat1, "c").Value = s1.Cells(r, "ı").Value
sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

 

[teonet]

Sayın Halit Bey
Elinize sağlık süper oldu, uyarınız için de teşekkür ederim

saygılar