Soru Makro Birleştirme

[Sefa1994]

Merhabalar, Dün Bi arkadaşımız güncelle butonu ile benzersiz veri aktarımı hakkında yardımcı olmuştu ve aşağıda ki kodu yazmıştı tekrar ondan yardım isteyip rahatsız etmek istemedim o yüzden size sorayım dedim. Bu kodda sayfa 1 deki b sütununda olan benzersiz verileri sayfa 2 de ki a40 ve altına benzersiz olanları ekliyordu tekrar edilenleri eklemiyordu. Ben bununla beraber safa 1 deki b sütunun yanında I sütununda olan yazıları da sayfa 2 de ki b 40 ve altına yazdırmak istiyorum. şöyle ki; sayfa 1 b sütunu ve onun yanında yazan I sütununda ki veriyi sayfa 2 de a 40 ve yanında b 40 a ekle yardımcı olabilirseniz çok sevinirim. isteyene excel şablonunu da gönderirim. şimdiden teşekkürler..

Sub aktar()
Dim son
Dim son2
Dim i
son = Sheets("Sayfa1").Cells(Rows.Count, 2).End(3).Row
son2 = Sheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row
If son2 >= 39 Then GoTo atla:

Sheets("Sayfa2").Range("a40:a" & son2).ClearContents
atla:
For i = 2 To son
son2 = Sheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row
If WorksheetFunction.CountIf(Sheets("Sayfa2").Range("a1:a" & son2), Sheets("Sayfa1").Cells(i, 2)) = 0 Then
Sheets("Sayfa2").Cells(son2 + 1, 1).Value = Sheets("Sayfa1").Cells(i, 2).Value
End If

Next
End Sub

 

[Sefa1994]

Yardımcı olabilecek var mı?

 

[YUSUF44]

Deneyiniz, örnek dosya olmadığından ben deneyemedim:

Sub aktar()
Dim son
Dim son2
Dim i
son = Sheets("Sayfa1").Cells(Rows.Count, 2).End(3).Row
son2 = Sheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row
If son2 >= 39 Then GoTo atla:
Sheets("Sayfa2").Range("a40:a" & son2).ClearContents

    atla:
For i = 2 To son
    son2 = Sheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row
    If WorksheetFunction.CountIf(Sheets("Sayfa2").Range("a1:a" & son2), Sheets("Sayfa1").Cells(i, 2)) = 0 Then
        Sheets("Sayfa2").Cells(son2 + 1, "A").Value = Sheets("Sayfa1").Cells(i, "B").Value
        Sheets("Sayfa2").Cells(son2 + 1, "B").Value = Sheets("Sayfa1").Cells(i, "I").Value
    End If
Next
End Sub

 

[Sefa1994]

tekrarsız aktarma2 (5).xlsm

View and download from Yandex Disk

yadi.sk

 

[Sefa1994]

linki buraya bıraktım hocam düğmeye tıklayınca sayfa 1 deki a ve b sütunlarından sayfa 2 deki a 40 ve b 40 a gitmesi gerekiyor. ama tekrarsız olarak 2 kere tekrarlanan veriler 1 kere gidecek sadece. Kodu da buraya yazdım tekrar.

Sub aktar()
Dim son
Dim son2
Dim i
son = Sheets("Sayfa1").Cells(Rows.Count, 2).End(3).Row
son2 = Sheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row
If son2 >= 39 Then GoTo atla:

Sheets("Sayfa2").Range("a40:a" & son2).ClearContents
atla:
For i = 2 To son
son2 = Sheets("Sayfa2").Cells(Rows.Count, 1).End(3).Row
If WorksheetFunction.CountIf(Sheets("Sayfa2").Range("a1:a" & son2), Sheets("Sayfa1").Cells(i, 2)) = 0 Then
Sheets("Sayfa2").Cells(son2 + 1, 1).Value = Sheets("Sayfa1").Cells(i, 2).Value
End If

Next
End Sub

 

[Sefa1994]

Sizin yazdığınız kodda a40 a gidiyor fakat b40 a gitmiyor yazılanlar

 

[YUSUF44]

Kod kodda yazılan işlemi tam olarak yapıyor. Ya ne yapmak istediğinizi tam anlatamadınız ya da dosyanızı uygun hazırlamadınız. Kodun ne yaptığını anlatayım:

Önce Sayfa2'nin A sütunundaki son dolu satır numarasını buluyor. Eğer bu sayı 38'den büyükse Sayfa2'nin A sütununda 39. satırın altındaki verileri siliyor.

Sonra sırasıyla Sayfa1'in B sütunundaki veriyi Sayfa2'nin A sütununda arıyor. Eğer sayfa1'in B sütunundak iveri Sayfa2'nin A sütununda yoksa Sayfa1'in B sütunundaki veriyle I sütunundaki veriyi Sayfa2'nin altına ekliyor.

Örnek olarak dosyanızda Sayfa1'în B8 hücresine Ali ve I8 hücresine 1 yazıp düğmeye bastığımda bu veriler Sayfa2'ye eklendi.

 

[Sefa1994]

çok teşekkürler hocam ben bi şeyi eksik yapıyormuşum kopyalayıp düzenlerken. tekrar saolun