Diğer sayfaya taşıma

[VeliDemir]

Merhaba.

Bir Excel dosyasının birinci sayfasının A sütunundaki kelimelerin yanında olan B sütununda o kelimelerin karşılıkları yer almaktadır.

Excel dosyasının birinci sayfasının A sütunundaki bir kelimenin karşılığı olmadığı zaman, B sütunundaki ilgili hücrede - işareti yer almaktadır.

Bu Excel dosyasının birinci sayfasının A sütunundaki karşılığı olmayan kelimeleri, aynı Excel dosyasının ikinci sayfasının A sütununa aktaran bir makro programını sizlerden rica ediyorum.

İyi günler.

NOT: Programın çalışmasını gösteren örnek Excel dosyaları Zip dosyasının içinde yer almaktadır.

 

[chngrcn]

Kodunuz aşağıdaki gibidir, inceleyiniz. Saygılar..

Sub aktarma() ' coded by CİHANGİR...
On Error Resume Next

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

sat = s2.[A65536].End(3).Row + 1

s2.Range("A1:DM65536").ClearContents
Application.ScreenUpdating = False

For i = 1 To s1.[A65536].End(3).Row

    If s1.Cells(i, 2).Value = "-" Then
    
    s2.Cells(sat, 2).Value = s1.Cells(i, 2).Value
    s2.Cells(sat, 1).Value = s1.Cells(i, 1).Value
    
    
    sat = sat + 1
   
    s1.Cells(i, 2).Delete Shift:=xlUp
    s1.Cells(i, 1).Delete Shift:=xlUp
    
End If

Next

MsgBox " Aktarım tamamlanmıştır.. ", , ""
Application.ScreenUpdating = True


End Sub

 

[VeliDemir]

Bir düzeltme gerek

Merhaba Cihangir Bey.

Yardımlarınızdan ötürü size çok teşekkür ederim.

Makro programını bir Excel dosyasında denedim ve bazı kelimeleri taşımadığını tespit ettim.

Bundan ötürü, Excel dosyasının üçüncü sayfasına taşınması gereken kelimelerin hepsini yazdım ve makro programını bu Excel dosyası üzerinden düzeltmenizi sizden rica ediyorum.

Saygılarla.

NOT: Excel dosyası ekte yer almaktadır.

 

[chngrcn]

dosyaniz ektedir, inceleyiniz.. iyi geceler..

Sub aktarma() ' coded by CİHANGİR...
On Error Resume Next

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
s2.Range("A1:DM65536").ClearContents
s3.Range("A1:DM65536").ClearContents


sat = s2.[A65536].End(3).Row
sut = s3.[A65536].End(3).Row


Application.ScreenUpdating = False

For i = 1 To s1.[A65536].End(3).Row

    If s1.Cells(i, 2).Value = "-" Then
    
    s2.Cells(sat, 2).Value = s1.Cells(i, 2).Value
    s2.Cells(sat, 1).Value = s1.Cells(i, 1).Value
    
    sat = sat + 1
    
    Else
    
    s3.Cells(sut, 2).Value = s1.Cells(i, 2).Value
    s3.Cells(sut, 1).Value = s1.Cells(i, 1).Value
    
    
    sut = sut + 1
    
End If

Next

MsgBox " Aktarım tamamlanmıştır.. ", , ""
Application.ScreenUpdating = True


End Sub

 

[VeliDemir]

Cihangir bey size çok teşekkür ederim.

 

[chngrcn]

rica ederim.. iyi çalışmalar..