Listeleri alt alta aktarma

[NADİR YILDIZ]

Arkadaşlar merhaba
Sarı olarak renklendirilmiş olan sütünlardaki verileri
kontrol sayfasında Fatura listesi başlığının altına alt alta nasıl aktarım yapabilirim

 

[hamitcan]

Chatgpt ile yapılmış çözüm.

Sub JL_Sutunlarini_Aya_Aktar()

    Dim wsKaynak As Worksheet
    Dim wsHedef As Worksheet
    Dim sonSatirJ As Long
    Dim sonSatirL As Long
    Dim i As Long
    Dim hedefSatir As Long
    
    ' SAYFA İSİMLERİNİ BURAYA YAZ
    Set wsKaynak = ThisWorkbook.Sheets("E-FATURA EKSİK BUL")   ' Verilerin olduğu sayfa
    Set wsHedef = ThisWorkbook.Sheets("KONTROL")    ' Yapıştırılacak sayfa
    
    ' Hedef A sütununu temizle
    wsHedef.Range("A2:A5000").ClearContents
    
    ' Son dolu satırları bul
    sonSatirJ = wsKaynak.Cells(wsKaynak.Rows.Count, "J").End(xlUp).Row
    sonSatirL = wsKaynak.Cells(wsKaynak.Rows.Count, "L").End(xlUp).Row
    
    hedefSatir = 2
    
    ' J sütununu kopyala
    For i = 2 To sonSatirJ
        If wsKaynak.Cells(i, "J").Value <> "" Then
            wsHedef.Cells(hedefSatir, "A").Value = wsKaynak.Cells(i, "J").Value
            hedefSatir = hedefSatir + 1
        End If
    Next i
    
    ' L sütununu altına ekle
    For i = 2 To sonSatirL
        If wsKaynak.Cells(i, "L").Value <> "" Then
            wsHedef.Cells(hedefSatir, "A").Value = wsKaynak.Cells(i, "L").Value
            hedefSatir = hedefSatir + 1
        End If
    Next i
    
    MsgBox "J ve L sütunları başarıyla birleştirildi.", vbInformation

End Sub

 

[NADİR YILDIZ]

Sayın hamitcan çok teşekkür ederim
gayet güzel yapılmış gerçekten

ilave olarak her iki sütunda renkli olanların karşısına C sütununa elle X koyarak filtreliyorum

bunları makro ile nasıl X koyabilirim
Chatgpt bunada çözüm bulurmu acaba ?

 

[hamitcan]

Doğru mu anladım bilmiyorum aşağıdaki şekilde dener misiniz ? Bu arada siz de yapay zekadan faydalanabilirsiniz tabii ki doğru komutları vermek kaydıyla...

Sub DolguRengineGoreX()

    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("Kontrol") ' Sayfa adını değiştir
    
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To sonSatir
        
        ' Hücrede dolgu rengi var mı kontrol et
        If ws.Cells(i, "A").Interior.ColorIndex <> xlNone Then
            ws.Cells(i, "C").Value = "X"
        Else
            ws.Cells(i, "C").ClearContents
        End If
        
    Next i
    
    MsgBox "İşlem tamamlandı.", vbInformation

End Sub

 

[NADİR YILDIZ]

Sayın hamitcan
A ve B Sütunundakileri renklendiriyoruz buraya kadar tamam
bu renklendirdiklerimizi C sütunundaki mavi hücrelerdeki gibi X koymasını istiyorum
X lere göre filtreleme yapmak istiyorum

teşekkürler

 

[hamitcan]

Koşullu biçimlendirme varmış. Vallahi onu da yaptı.

Sub KosulluRengeGoreX()

    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("kontrol") ' Sayfa adını değiştir
    
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To sonSatir
        
        ' Hücrenin görünen dolgu rengine bak
        If ws.Cells(i, "A").DisplayFormat.Interior.ColorIndex <> xlColorIndexNone Then
            ws.Cells(i, "C").Value = "X"
        Else
            ws.Cells(i, "C").ClearContents
        End If
        
    Next i

    MsgBox "Koşullu biçimlendirme dahil kontrol tamamlandı.", vbInformation

End Sub

 

[NADİR YILDIZ]

Sayın Hamitcan
çok teşekkür ederim ancak b sütunundaki renklendirme olmasına rağmen X koymamış
yapmaya çalıştım ancak olmadı

iyi çalışmalar

 

[NADİR YILDIZ]

sayın hamitcan
Chatgpt ile güncelledim fazlasını bile yaptı X + filtreleme + çerçeve atma

işime yaradı teşekkür ederim


teşekkür ederim