Verileri yan yana aktarmak

[gezgin-49]

sayın üstadlarım A1:A1000 hücresine kadar yukarıdan aşağıya kadar olan tek ve çift sayılar var, Tek sayıları C1:M500 hücresine yan yana çift sayıları da N1:V500 hücresine yan yana aktarmak istiyorum, bunun için nasıl bir kod oluşturmam lazım

 

[Erdem Akdemir]

Merhaba,

Yanyana nasıl bir sıralama ile aktarılacak.
Sorunuz net değil.

 

[gezgin-49]

tek sayıları c1,d1,e1,f1,g1,h1,ı1,j1,k1,l1,m1
c2,d2,e2,....................................m2
c3,d3,........................................ m3


aynı şekilde çift sayıları da
n1,o1,p1,r1,s1..............v1
n2,o2..............................v2
n3,o3.............................v3

şeklinde aktarması gerekiyor

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub tekcift()

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

For i = 1 To son
    If WorksheetFunction.IsOdd(Cells(i, "A")) = True Then
        If [C1] = "" Then
            [C1] = Cells(i, "A")
        Else
            Set c = [C1:M500].Find(What:="", SearchOrder:=xlByRows)
            If Not c Is Nothing Then
                c.Select
                ActiveCell = Cells(i, "A")
            End If
        End If
    Else
        If [N1] = "" Then
            [N1] = Cells(i, "A")
        Else
            Set d = [N1:V500].Find(What:="", SearchOrder:=xlByRows)
            If Not d Is Nothing Then
                d.Select
                ActiveCell = Cells(i, "A")
            End If
        End If
    End If
Next

End Sub

 

[gezgin-49]

If WorksheetFunction.IsOdd(Cells(i, "A")) = True Then

kodda hata uyarısı yapıyor

 

[yanginci34]

Sizin sayılarınız A1 hücresinden başladığına eminmisiniz ?

 

[gezgin-49]

a1 hücresinden başlıyor

 

[yanginci34]

Sayın Yusuf Hocamın kodu benim dosyamda sorunsuz çalışıyor incelermisiniz.
http://dosya.co/uuu0vgoclu70/tek_çift_sayıları_yatay_ayırma.xlsm.html

 

[gezgin-49]

bizim internet kısıtlı onun için sayfayı açmıyor.

ben excel 2003 kullanıyorum

 

[Korhan Ayhan]

Versiyondan dolayı sorun yaşıyorsunuz.

Aşağıdaki kodu deneyiniz.

Sub Tek_Cift_Sayi_Aktar()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Range("C1:V500").ClearContents
    TSatir = 1: TSutun = 3
    CSatir = 1: CSutun = 14
    
    For Each Veri In Range("A1:A1000")
        If Veri.Value Mod 2 <> 0 Then
            Cells(TSatir, TSutun) = Veri.Value
            If TSutun = 13 Then
                TSutun = 3
                TSatir = TSatir + 1
            Else
                TSutun = TSutun + 1
            End If
        Else
            Cells(CSatir, CSutun) = Veri.Value
            If CSutun = 22 Then
                CSutun = 14
                CSatir = CSatir + 1
            Else
                CSutun = CSutun + 1
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[gezgin-49]

Sayın Üstadım Korhan AYHAN Allah razı olsun, ayrıca Yusuf44 ve Yanginci34 üstadlarım sizlerden de Allah razı olsun, çoooook teşekkür ediyorum.

 

[yanginci34]

Sayın Üstadım Korhan AYHAN Allah razı olsun, ayrıca Yusuf44 ve Yanginci34 üstadlarım sizlerden de Allah razı olsun, çoooook teşekkür ediyorum.

Rica ederim.

GM 8 d cihazımdan Tapatalk kullanılarak gönderildi