Sayfadan Sayfaya Seçili Sütunlar Aktarma

[Hsn55]

İyi günler;
Ekli dosyada kayıtlar sayfasındaki belirli sütunlardaki verileri yine kontrol sayfasında ki belirli sütunlara aktarmak istiyorum. Şartları aşağıya çıkardım desteğinizi bekliyorum. Saygılarımla.

İndir AKTAR

Dosyayı indir AKTAR

dosya.co

1-Aktarma işlemi sadece Kayıtlar sayfasında Y4:Y sütununda "Aktif" yazılı satırlar aktarılacak
2-Konrol Sayfasında 25,26,27 satırlar ne kadar satır aktarılsa da en sonda kalacak.
3-Kayıtlar Sayfasında A4:A sütunundaki verileri Kontrol Sayfasında C8:C hücresine aktarılacak (Not: Kontrol sayfasına aktarılan satırlara sıra numarası otomatik verilecek)
-Kayıtlar Sayfasında B4:B sütunundaki verileri Kontrol Sayfasında L8:L hücresine aktarılacak
-Kayıtlar Sayfasında C4:C sütunundaki verileri Kontrol Sayfasında G8:G hücresine aktarılacak
-Kayıtlar Sayfasında D4: D sütunundaki verileri Kontrol Sayfasında H8:H hücresine aktarılacak
-Kayıtlar Sayfasında E4:E sütunundaki verileri Kontrol Sayfasında D8: D hücresine aktarılacak
-Kayıtlar Sayfasında W4:X sütunundaki verileri Kontrol Sayfasında J8:K hücresine aktarılacak
-Kayıtlar Sayfasında T4:U sütunundaki verileri Kontrol Sayfasında M8:N hücresine aktarılacak

 

[Hsn55]

Sayın değerli hocalarım. Konuya desteğinizi bekliyorum. Saygılarımla

 

[Muzaffer Ali]

Dosyanız ekte.

 

[Hsn55]

Hocam rica etsem link olarak ekleyebilir misiniz. Yada makroyu

 

[Muzaffer Ali]

Option Explicit

Sub test()
    Dim syfKayitlar As Worksheet, syfKontrol As Worksheet
    Dim Bak As Long, Say As Long
    
    Set syfKayitlar = ThisWorkbook.Worksheets("KAYITLAR")
    Set syfKontrol = ThisWorkbook.Worksheets("KONTROL")
    
    Say = syfKontrol.Cells(Rows.Count, "C").End(xlUp).Row
    If Say > 7 Then syfKontrol.Rows("8:" & Say).Delete
        
    For Bak = 4 To syfKayitlar.Cells(Rows.Count, "A").End(xlUp).Row
        If syfKayitlar.Cells(Bak, "Y") = "Aktif" Then
            Say = syfKontrol.Cells(Rows.Count, "C").End(xlUp).Row + 1
            syfKontrol.Rows(Say).Insert
            syfKontrol.Cells(Say, "C").Value = Say - 7
            syfKontrol.Cells(Say, "L").Value = syfKayitlar.Cells(Bak, "B").Value
            syfKontrol.Cells(Say, "G").Value = syfKayitlar.Cells(Bak, "C").Value
            syfKontrol.Cells(Say, "H").Value = syfKayitlar.Cells(Bak, "D").Value
            syfKontrol.Cells(Say, "D").Value = syfKayitlar.Cells(Bak, "E").Value
            syfKontrol.Cells(Say, "J").Value = syfKayitlar.Cells(Bak, "W").Value
            syfKontrol.Cells(Say, "M").Value = syfKayitlar.Cells(Bak, "T").Value
        End If
    Next
    SatirKenarlik syfKontrol, Say
    MsgBox "İşlem tamamlandı.", vbInformation
End Sub

Sub SatirKenarlik(syf As Worksheet, Satir As Long)
    With syf.Range("C8:N" & Satir)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
End Sub

 

[Hsn55]

Muzaffer hocam kontrol sayfasında 7 satırdan başlıyor. Fakat sıra numarasını 2 den başlatıyor

Say = syfKontrol.Cells(Rows.Count, "C").End(xlUp).Row
    If Say > 8 Then syfKontrol.Range("C8:N" & Say).ClearContents
    For Bak = 4 To syfKayitlar.Cells(Rows.Count, "A").End(xlUp).Row

 

[Muzaffer Ali]

Kodu düzelttim. Tekrar deneyin.

 

[Hsn55]

Muzaffer hocam. Son olarak şöyle bir şey yapılabilir mi?. Örneğin ben 200 satır aktardım. Kontrol sayfasına 200 satır aktarılıyor. Daha sonra 100 satırlık bir veri aktardım. 100 satır aktarılıyor. Fakat kontrol sayfasında diğer 100 satırı silebilir mi

 

[Muzaffer Ali]

Kodları yeniledim.

 

[Hsn55]

Muzaffer bir önceki makroda kontrol sayfasında biçimlendirmelerimi değiştirmiyordu. Şimdi değiştiriyor. Biçimlendirme ayın kalabilir mi?. Ayrıca tablo kontrol sayfasında içerisinde veri olmayan boş olan tabloları silmiyor.

 

[Muzaffer Ali]

Biçimlendirmeyi kaldırdım.
Kontrol sayfasında boş satırlar zaten siliniyordu.
Dosyanız ekte.

https://s6.dosya.tc/server5/q2r8ra/AKTAR__4_.xlsm.html

 

[Hsn55]

Kontrol sayfasında kenarlık biçimlendirmeyi değiştirmese olabilir mi?

 

[Muzaffer Ali]

Sadece başlığın altındaki çizgi ince oluyor, buradan mı bahsediyorsunuz?
Benim gözlemime göre başka bir fark yok.
düzeltmek için
Aşağıdaki kodları bulun

        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With

xlThin yerine aşağıdaki gibi xlMedium yazın.

        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With

Eğer farklı olan başka bir yer varsa belirtin.

 

[Hsn55]

kontrol sayfasındaki 7 satırdaki başlıkların bulunduğu hücreleri renkli yaptığımda tüm yerleri renkli yapıyor. San satırdaki alt kısmının biçimlendirmesini de başlığın altındaki çizgi gibi kalın olabilir mi?

 

[Muzaffer Ali]

11. mesajdaki dosyayı yeniledim.

 

[Hsn55]

Hocam gayet güzel oldu ellerinize sağlık. Aynı buton ile kayıtlar sayfasında S sütununda Bedelli ve Bedelsiz Y sütununda ise Aktif ve Pasif var. Aynı Buton ile Kontrol sayfasında K1 hücresine Bedelli/Aktif adedini ve K2 hücresine ise Bedelsiz/Aktif olanları makro ile nasıl toplatabilir miyiz ?

 

[Muzaffer Ali]

Aktar kodlarını aşağıdakiler ile değiştirin.

Sub Aktar()
    Dim syfKayitlar As Worksheet, syfKontrol As Worksheet
    Dim Bak As Long, Say As Long
    Dim Bedelli As Long, Bedelsiz As Long
    Set syfKayitlar = ThisWorkbook.Worksheets("KAYITLAR")
    Set syfKontrol = ThisWorkbook.Worksheets("KONTROL")
    Say = syfKontrol.Cells(Rows.Count, "C").End(xlUp).Row
    If Say > 8 Then syfKontrol.Rows("9:" & Say).Delete
    syfKontrol.Rows("8:8").ClearContents
    For Bak = 4 To syfKayitlar.Cells(Rows.Count, "A").End(xlUp).Row
        If syfKayitlar.Cells(Bak, "Y") = "Aktif" Then
            If syfKayitlar.Cells(Bak, "S") = "Bedelli" Then
                Bedelli = Bedelli + 1
            Else
                Bedelsiz = Bedelsiz + 1
            End If
            Say = syfKontrol.Cells(Rows.Count, "C").End(xlUp).Row + 1
            syfKontrol.Cells(Say, "C").Value = Say - 7
            syfKontrol.Cells(Say, "L").Value = syfKayitlar.Cells(Bak, "B").Value
            syfKontrol.Cells(Say, "G").Value = syfKayitlar.Cells(Bak, "C").Value
            syfKontrol.Cells(Say, "H").Value = syfKayitlar.Cells(Bak, "D").Value
            syfKontrol.Cells(Say, "D").Value = syfKayitlar.Cells(Bak, "E").Value
            syfKontrol.Cells(Say, "J").Value = syfKayitlar.Cells(Bak, "W").Value
            syfKontrol.Cells(Say, "M").Value = syfKayitlar.Cells(Bak, "T").Value
            syfKontrol.Rows(Say + 1).Insert
        End If
    Next
    SatirKenarlik syfKontrol, Say
    syfKontrol.Range("K1") = Bedelli
    syfKontrol.Range("K2") = Bedelsiz
    MsgBox "İşlem tamamlandı.", vbInformation
End Sub

 

[Hsn55]

Muzaffer hocam çok çok teşekkür ederim. Butona kaç birkaç sefer bastığım zaman İmza kısmı ile son satırın arası butona bastığımda açılıyor.Nasıl engelleriz

 

[Muzaffer Ali]

11. mesajdaki dosyayı yeniledim.

 

[Hsn55]

11. mesajdaki dosyayı yeniledim.

Emeğinize sağlık hocam. Çok teşekkür ederim.Saygılarımla