Makro ile çift sayıları ayırma

[ayşe006]

arkadaşlar örnek dosyada gönderdiğim sadece a sutunu için makro kodu ile çiftlerin ayrılıp 2. sayfaya geçmesini istiyorum. bunu yapmak için koşullu biçimlendirme kullanmayı denedim ama bu bir örnek dosya ikiyüzbin hücre verisini malesef kaldırmıyor. bunun için bi makro kodu varmı varsa sevinirim..

 

[halit3]

kod:

Sub Makro1()
sayfa_adi1 = "Sayfa1"
sayfa_adi2 = "Sayfa2"
sat = 0
For r = 1 To Worksheets(sayfa_adi1).Cells(Rows.Count, "A").End(3).Row
a = Val(Sheets(sayfa_adi1).Cells(r, "A")) / 2
If a = Int(a) Then
sat = sat + 1
Sheets(sayfa_adi2).Cells(sat, "A").Value = Sheets(sayfa_adi1).Cells(r, "A").Value
Else
End If
Next
End Sub

 

[ayşe006]

hocam olmadı bu örnek dosyada çalışmadı eror verdi

 

[ayşe006]

hocam a sutnun çiftlerini ayırırken komple hücre genişletmeside lazım hocam.

 

[Murat OSMA]

hocam olmadı bu örnek dosyada çalışmadı eror verdi

Bende hatasız sonuç verdi.
Sizin eklediğiniz dosya ile asıl kullandığınız dosya farklı olabilir.
Kodlar; her değişiklikte farklı sonuçlar verir, hata verir, ya da hiçbir sonuç vermez. O yüzden örnek dosya eklersen asıl dosya formatında eklemek gerek.

Alternatif olarak bu kodları kullanabilirsiniz..
Yine hata alırsanız yukarıda bahsettiğim durum söz konusudur.

[SIZE="2"]Sub Emre()
    Dim i&, a&
    For i = 1 To Sayfa1.Cells(Rows.Count, "A").End(3).Row
        If WorksheetFunction.IsEven(Sayfa1.Cells(i, 1).Value) Then
            a = a + 1
            Sayfa2.Cells(a, 1).Value = Sayfa1.Cells(i, 1).Value
        End If
    Next i
    Sayfa2.Columns.AutoFit
    a = Empty: i = Empty
End Sub[/SIZE]

 

[ayşe006]

Hocam örnek dosyamı attım normalde bunları koşullu biçimlendirmede rahat yapabiliyorum. Ama veri çok fazla olduğu için excel donuyor. 1. örnek asıl dosyam 2. Ornek resim makro kodu çalıştırdıktan sonra çıkan veri. Asıl istediğim ise 3. örnek dosyamda mevcut. (hocam normalde çiftleri koşullu biçimlendirme ile kırmızı ile boyayıp bunu filitre yöntemi ile ayırabiliyorum. benim istediğim bu işlemin makro kodu.ve çiftleri boyamasına da gerek yok 1. sayfadaki a sutunundan çiftleri alıp 2. sayfaya atacak bunu yaparken hücre genişlemesi de yapacak.)

 

[halit3]

KOD:

Sub Makro1()
sayfa_adi1 = "Sayfa1"
sayfa_adi2 = "Sayfa2"
sat = 0

Sheets(sayfa_adi2).Columns("A:F").ClearContents

For r = 1 To Worksheets(sayfa_adi1).Cells(Rows.Count, "A").End(3).Row
a = Val(Sheets(sayfa_adi1).Cells(r, "A")) / 2
If a = Int(a) Then
sat = sat + 1
Sheets(sayfa_adi2).Cells(sat, "A").Value = Sheets(sayfa_adi1).Cells(r, "A").Value
Sheets(sayfa_adi2).Cells(sat, "B").Value = Sheets(sayfa_adi1).Cells(r, "B").Value
Sheets(sayfa_adi2).Cells(sat, "C").Value = Sheets(sayfa_adi1).Cells(r, "C").Value
Sheets(sayfa_adi2).Cells(sat, "D").Value = Sheets(sayfa_adi1).Cells(r, "D").Value
Sheets(sayfa_adi2).Cells(sat, "E").Value = Sheets(sayfa_adi1).Cells(r, "E").Value
Sheets(sayfa_adi2).Cells(sat, "F").Value = Sheets(sayfa_adi1).Cells(r, "F").Value
Else
End If
Next

Sheets(sayfa_adi2).Columns("A:F").EntireColumn.AutoFit

End Sub

 

[ayşe006]

hocam örnek 1 yapmak istediğim şey, makrolu örnek dosyasıda makroyu çalıştırdıktan sonraki aldığım sonuç. 2. sayfada. çift olmayanları da almış. ben yanlış bişeymi yapıyorum anlamadımki dosyaları ekledim.

 

[Murat OSMA]

Çift sayı nedir Sn. ayşe006 ? :hiho: ​

 

[ayşe006]

örnek : a1 ile a2 hücresindeki rakamların aynı olması çift oluyor. :arkadas:

 

[halit3]

Şimdi zamanım yok daire kapanıyor evde de net yok sorunuz ya yanlış soruldu yada ben yanlış anladım.

Makro ile çift sayıları ayırma

buradan anlaşılan sayıların tek mi çiftmi olduğu örnek dosyanızda ise aynı değerden birden fazla olması
hangisi şimdi ?

Formda mükerrer diye arama yapın yada benzersiz diye arama yapın bir çok konu bulacaksınız.

 

[halit3]

Mükerrerleri teke düşüren kod:

Sub Makro2 ()


ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set s1 = Sheets("Sayfa1") ' veri sayfası
Set S2 = Sheets("Sayfa2") 'aktarılan sayfa

S2.Columns("A:F").ClearContents

son1 = s1.Cells(Rows.Count, "A").End(3).Row

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

For j = [COLOR="Red"]1 [/COLOR]To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "A"))
ara2(j) = 1
Next j

sat1 = 0

For r = [COLOR="red"]1[/COLOR] To son1
aranan1 = ara1(r)

sut13 = 0
sut14 = 0
sut15 = 0

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
ara2(i) = 0
End If
Next i
sat1 = sat1 + 1
For t = 1 To 6
S2.Cells(sat1, t).Value = s1.Cells(r, t).Value
Next

End If
Next r
S2.Columns("A:F").EntireColumn.AutoFit
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
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

Mükerrer olanlar

Sub Makro3 ()

ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set s1 = Sheets("Sayfa1") ' veri sayfası
Set S2 = Sheets("Sayfa2") 'aktarılan sayfa

S2.Columns("A:F").ClearContents

son1 = s1.Cells(Rows.Count, "A").End(3).Row

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

For j = [COLOR="red"]1[/COLOR] To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "A"))
ara2(j) = 1
Next j

sat1 = 0

For r = [COLOR="red"]1[/COLOR] To son1
aranan1 = ara1(r)

sut13 = 0
sut14 = 0
sut15 = 0

If ara2(r) = 1 Then

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

If deg > 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sat1 = sat1 + 1
For t = 1 To 6
S2.Cells(sat1, t).Value = s1.Cells(r, t).Value
Next
End If
Next i

End If


End If
Next r
S2.Columns("A:F").EntireColumn.AutoFit
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
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

 

[ayşe006]

ellerinize sağlık ama hocam ben koddan anlamam ki alıp kopyalıyorum "çalıştıramadım." Dediğiniz gibi mükerrer kayıtlar olacak. arşivinize baktım. hatta kod dosyası vardı onada baktım ama ben "sayfa 1" A sütunu mükerrerleri silmeden 2. sayfaya hücre genişleterek aktarmasını istiyorum hiçbir veri silinmeyecek. Hücre genişlemesini Z sütünuna kadar yapabilmeli. yaptığım işlem -makroyu kaydet- makroyu görüntüle-düzenle-insert-module- kopyala yapıştır yapıp çalıştırıyorum. acaba ben mi yanlış yapıyorum ? 2007 Excel kullanıyorum. emekleriniz için teşekkürler.

 

[halit3]

Dosyanız ektedir.

 

[ayşe006]

tmmdır istediğim gibi oldu ellllllerrinize sağlıkkkk son bişey daha kodlardaki (J) OLAN YERLER J sütunu içinse (Z) İLE DEĞİŞTİREBİLİRMİYİM ?

 

[ayşe006]

Hocam mükerrerleri teke indirirken liste 29 kişilik liste 10 mükerrer kayıt var tekini silersen 5 mükerrer silmesi lazım, ama 22 kişi kalıyor... A1 ve a2 hücresini almamış hocam....

 

[halit3]

Hocam mükerrerleri teke indirirken liste 29 kişilik liste 10 mükerrer kayıt var tekini silersen 5 mükerrer silmesi lazım, ama 22 kişi kalıyor... A1 ve a2 hücresini almamış hocam....

14 nolu mesajdaki dosyayı güncelledim.

 

[ayşe006]

Ellerinize sağlık çok teşekkür ederim iyi çalışmalar...

 

[halit3]

Ellerinize sağlık çok teşekkür ederim iyi çalışmalar...

Teşekkürler iyi çalışmalar

 

[ayşe006]

üstadım ufak bir sorunum var... A SÜTUNU MÜKERRERLERİ AYIRIRKEN, B SÜTUNU İÇİNDE DEĞİŞKEN VERİYİ MÜKERRER ATAMA YAPIYOR. ÖRNEK DOSYADA MAVİ OLAN YERLER MAKRO ÇALIŞTIKTAN SONRA MÜKERRER OLUYOR. SATIRDA HİÇBİR DEĞİŞİKLİK YAPMAMASI LAZIM. BİDE HOCAM HÜCRE GENİŞLEMESİ YAPAMADIM BİR TÜRLÜ. (V) SÜTUNUNA KADAR HİÇBİR HÜCRE SİLİNMEDEN DEĞİŞMEDEN AYNEN 2. SAYFAYA GEÇECEK. YAPAMADIM... YARDIMCI OLURSANIZ SEVİNİRİM.