koşullu makro oluşturmak

[centied]

Öncelikle herkese selamlar,
Sitede yeni üyeyim. Filtre ile sorunumu çözebiliyorum fakat 60-70 bin satırda çok yorucu oluyor. Excelde makrolar üzerinde çalışmaya başladım, fakat bir sorunum var yardımcı olursanız sevinirim.

A B
x 1
x 2
y 3
y 4
y 5
z 6
z 7
z 2
z 8

B sutununda 2 nin olduğu ve A sutununda 2 nin geçtiği x ve z kümesine ait bütün satırları başka bir sayfaya kopyalamak istiyorum.Örnekte olduğu gibi...
A B
x 1
x 2

z 6
z 7
z 2
z 8
Şimdiden teşekkür ederim.

 

[asi_kral]

Dosyanızı göremedim

 

[centied]

Bahsettiğim şekilde b sutununda geçen bazı sayıların geçtiği a sutunundaki bütün "id" kümesini ikinci sayfaya taşımak istiyorum. Örnek verecek olursak b sutununda 142 geçen bütün id kümeleri gibi.

 

[asi_kral]

Bahsettiğim şekilde b sutununda geçen bazı sayıların geçtiği a sutunundaki bütün "id" kümesini ikinci sayfaya taşımak istiyorum. Örnek verecek olursak b sutununda 142 geçen bütün id kümeleri gibi.

Benim anladığım kadarı ile kodu siz belirleyeceksiniz o koda göre Id numarası ve kodu diğer sayfaya alacak doğru mudur_?

 

[centied]

B sutununda olan kodlar çeşitli, ben sadece içindeki 4-5 tane kodla ilgili filtreleme yapmam gerekiyor. Fakat problem şu ki; bu kodlara ait id ler her ay değişmekte. Dolayısıyla 142 koduna ait id yi bulup o id ye ait bütün satırları taşımam gerekiyor. İlginiz için teşekkür ederim.

 

[asi_kral]

B sutununda olan kodlar çeşitli, ben sadece içindeki 4-5 tane kodla ilgili filtreleme yapmam gerekiyor. Fakat problem şu ki; bu kodlara ait id ler her ay değişmekte. Dolayısıyla 142 koduna ait id yi bulup o id ye ait bütün satırları taşımam gerekiyor. İlginiz için teşekkür ederim.

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub koda_göre_aktar_1967()
'Konu       :   Kod numarasına Göre Aktarım
'Mail       :   m.batu.1967@gmail.com
'Coder By   :       asi_kral_1967
Dim asi, kral, sorgu
Dim a, b, c
Set asi = Sheets("Sayfa1")
Set kral = Sheets("Sayfa2")
sorgu = InputBox("Kod Giriniz", "Kod Girişi")
If sorgu = Empty Then Exit Sub
kral.Range("A3:B" & Rows.Count).ClearContents
kral.Select
b = ActiveCell.Address
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("A2:B" & a).AutoFilter field:=2, Criteria1:=sorgu * 1
If WorksheetFunction.Subtotal(3, asi.Range("A3:A" & a)) > 0 Then
asi.Range("A3:B" & a).Copy
kral.Range("A3").PasteSpecial (xlPasteValues)
End If
asi.Range("A2:B" & a).AutoFilter
Range(b).Select
MsgBox sorgu & " Verilerini Aktardım", vbInformation, "asi_kral_1967"
End Sub

Eki inceleyin lütfen

 

[centied]

Üstad teşekkür ederim fakat makroyu çalıştıramadım. Sizin gönderdiğinizi de inceledim ama eksik bir dosya mı var?

 

[asi_kral]

Üstad teşekkür ederim fakat makroyu çalıştıramadım. Sizin gönderdiğinizi de inceledim ama eksik bir dosya mı var?

Üstteki dosyada bir problem görmedim.
Sadece buton'a Makro atamayı unutmuşum
Güncelledim.

 

[centied]

Pardon Üstad, uzun zamandır bilgisayar başında olmayınca acele ettim heralde Şimdi Makro çalışıyor fakat 142 kodunun geçtiği bütün satırları getirmiş ama "id" sutunundaki bütün kümeyi getirmemiş.

 

[asi_kral]

Pardon Üstad, uzun zamandır bilgisayar başında olmayınca acele ettim heralde Şimdi Makro çalışıyor fakat 142 kodunun geçtiği bütün satırları getirmiş ama "id" sutunundaki bütün kümeyi getirmemiş.

Size onu sormuştum biraz önce ben
Siz Kod'a göre Gelecek dediğiniz için bende ona göre getirmiştim.
Tam olarak istediğinizi daha net anlatır mısınız_?

 

[centied]

Şablonun son halini ekledim. Teşekkür ederim.

 

[centied]

Kusura bakmayın. Derdimi anlatmada biraz sıkıntı olmuş olabilir. Benim istediğim b sutununda 142 geçen bütün satırları getirsin. burda problem yok. Fakat buna ek olarak 142 ye karşılık gelen o getirdiği satırlardaki bütün "id" leri satır olarak taşısın.

 

[asi_kral]

Şablonun son halini ekledim. Teşekkür ederim.

Şimdi istediğinizi anladım.
Mesela 142 değeri 6000 civarında buluyor bunların tüm karşılıklarını aktarmasını istiyorsun sen.
Bu makro kodunda belli bir sürede işlem yapar. Buna razıysanız kodu yazayım.

 

[centied]

Üstad 60-70 bin satırda çalışarak bu filtremeleri yaptığım için bi süre beklemek bana ilaç gibi gelecektir Benim için sorun yok. Verdiğim zahmetin dışında bir rahatsızlığım yok. Tekrar kusura bakmayın, teşekkür ederim.

 

[asi_kral]

Üstad 60-70 bin satırda çalışarak bu filtremeleri yaptığım için bi süre beklemek bana ilaç gibi gelecektir Benim için sorun yok. Verdiğim zahmetin dışında bir rahatsızlığım yok. Tekrar kusura bakmayın, teşekkür ederim.

Merhaba
Moduledeki kodu bununla değiştirip deneyin.

Option Explicit
Sub koda_göre_aktar_1967()
'Konu       :   Kod numarasına Göre Aktarım
'Mail       :   m.batu.1967@gmail.com
'Coder By   :       asi_kral_1967
Dim asi, kral, sorgu
Dim a, b, c, d As New Collection, e
Set asi = Sheets("Sayfa1")
Set kral = Sheets("Sayfa2")
sorgu = InputBox("Kod Giriniz", "Kod Girişi")
If sorgu = Empty Then Exit Sub
Application.ScreenUpdating = False
kral.Range("A3:B" & Rows.Count).ClearContents
kral.Select
b = ActiveCell.Address
On Error Resume Next
For a = 3 To asi.Cells(Rows.Count, "A").End(xlUp).Row
If asi.Cells(a, "B") = sorgu * 1 Then
d.Add asi.Cells(a, "A"), CStr(asi.Cells(a, "A"))
End If
Next
For Each e In d
c = kral.Range("A" & Rows.Count).End(xlUp).Row + 1
a = asi.Range("B" & Rows.Count).End(xlUp).Row
asi.Range("A2:B" & a).AutoFilter field:=1, Criteria1:=e
If WorksheetFunction.Subtotal(3, asi.Range("A3:A" & a)) > 0 Then
asi.Range("A3:B" & a).Copy
kral.Range("A" & c).PasteSpecial (xlPasteValues)
End If
asi.Range("A2:B" & a).AutoFilter
Next
asi.Range("A2:B" & a).AutoFilter
Range(b).Select
Application.ScreenUpdating = True
MsgBox sorgu & " Verilerini Aktardım", vbInformation, "asi_kral_1967"
End Sub

Dosya ekte

 

[centied]

Üstad çok teşekkür ederim. Emeğini sağlık. Problem çözüldü.

 

[asi_kral]

Üstad çok teşekkür ederim. Emeğini sağlık. Problem çözüldü.

Kolay Gelsin.