Çözüldü Bir sütundaki verileri ayrı ayrı sayfalara kopyalamak

hadromer · 3 Ocak 2021

Merhaba,
bir sayfadaki sütunları hazır bir şablondaki T sütununa kopyalayarak her bir sütun için ayrı ayrı sayfalar olacak şekilde kopyalamak istiyorum. Örneğin kaynak sayfasında r4 başlıklı sütunu alıp şablon sayfasındaki yerine(T sütunu) kopyalayarak r4 adında yeni bir sayfa oluşturmak. Böyle bir makro hazırlayabilir miyiz ,Yardımcı olabilir misiniz ? Bu dosyayı da sürekli kullanmak istiyorum. Çünkü verilerim ve sütun sayılarım sürekli değişmektedir. Örnek dosya fotoğraflar aşağıdaki gibidir. Yardımlarınız için teşekkür ederim.

örnek dosya :
Ornek.xlsx dosyasını indir - download

fotoğraflar
https://i.hizliresim.com/xzld8x.png

https://i.hizliresim.com/ARImfV.png

muratboz4206 · 3 Ocak 2021

Merhaba,
Yeni bir module oluşturun ve aşağıdaki kodları kopyalayın.
iki tane R27 a , R12 a verisi var bunlar için kontrol yapmıyor. Birinci R27 a sütunu için R27 a sayfası oluşturur, ikinci R27 a sütünü için Şablon(x) isminde sayfa oluşur, isimlendirme yapmaz. Şablon(x) isimli sayfaların sayfa isimlerini ilgili sayfada T2 hücresindeki veriye i manuel olarak düzeltirsiniz.

Kod:

Sub SutunlariTasiveSayfalariOlustur()
    On Error Resume Next
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = FALSE
    Application.DisplayStatusBar = FALSE
    Application.EnableEvents = FALSE
    Dim kaynak As Worksheet
    Dim sablon As Worksheet
    
    Set kaynak = ThisWorkbook.Sheets("Kaynak")
    Set sablon = ThisWorkbook.Sheets("Şablon")
    
    sablon.Range("T:T").ClearContents
    sonSutun = kaynak.Range("XFD2").End(xlToLeft).Column
    sonSatir = kaynak.Range("A65536").End(xlUp).Row
    
    For i = 1 To sonSutun
        kaynak.Range(Cells(2, i), Cells(sonSatir, i)).Copy
        sablon.Range("T2").PasteSpecial
        sablon.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ActiveSheet.Name = kaynak.Cells(2, i).Value
        ActiveSheet.Range("T2").Select
        sablon.Range("T:T").ClearContents
        kaynak.Select
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = TRUE
    Application.DisplayStatusBar = TRUE
    Application.EnableEvents = TRUE
    MsgBox "İşlem tamamlandı."
End Sub

hadromer · 3 Ocak 2021

muratboz4206' Alıntı:

Merhaba,
Yeni bir module oluşturun ve aşağıdaki kodları kopyalayın.
iki tane R27 a , R12 a verisi var bunlar için kontrol yapmıyor. Birinci R27 a sütunu için R27 a sayfası oluşturur, ikinci R27 a sütünü için Şablon(x) isminde sayfa oluşur, isimlendirme yapmaz. Şablon(x) isimli sayfaların sayfa isimlerini ilgili sayfada T2 hücresindeki veriye i manuel olarak düzeltirsiniz.

Kod:

Sub SutunlariTasiveSayfalariOlustur()
    On Error Resume Next
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = FALSE
    Application.DisplayStatusBar = FALSE
    Application.EnableEvents = FALSE
    Dim kaynak As Worksheet
    Dim sablon As Worksheet
   
    Set kaynak = ThisWorkbook.Sheets("Kaynak")
    Set sablon = ThisWorkbook.Sheets("Şablon")
   
    sablon.Range("T:T").ClearContents
    sonSutun = kaynak.Range("XFD2").End(xlToLeft).Column
    sonSatir = kaynak.Range("A65536").End(xlUp).Row
   
    For i = 1 To sonSutun
        kaynak.Range(Cells(2, i), Cells(sonSatir, i)).Copy
        sablon.Range("T2").PasteSpecial
        sablon.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ActiveSheet.Name = kaynak.Cells(2, i).Value
        ActiveSheet.Range("T2").Select
        sablon.Range("T:T").ClearContents
        kaynak.Select
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = TRUE
    Application.DisplayStatusBar = TRUE
    Application.EnableEvents = TRUE
    MsgBox "İşlem tamamlandı."
End Sub

Hocam harika olmuş kod, çok teşekkür ederim. Evet sütun isimlerinde tekrar olmuş affedersiniz. Şimdi bir kaç sorum olacak hocam. Ben bu kaynak şablon dosyasını sürekli kullanacağım. Ama kaynak sayfasındaki veri ve sütun sayılarım değişkenlik gösterebiliyor. Bu kod yine de çalışır mı ? yani sütun sayılarımın değişmesi kod döngüsünde bir problem yaratır mı ?

İkincisi ve en önemli sorunumu ben konuyu açarken atlamışım. Affınıza sığınarak bir ricada daha bulunmak istiyorum. oluşturulan sayfalarda "AD" ve "AE" sütunlarında bir işlem daha gerekiyor. Hocam eğer AE sütununda içinde değer olan bir hücrenin AD sütunundaki komşu hücresi boş veya sıfır ise AE sütunundaki hücreninde silinmesi gerekiyor. aşağıya bir fotoğraf ekledim sarı renkte örnek hücreler. sarı hücrenin sol komşusu boş olduğu için onunda olmaması gerekiyor yani. BÖyle bir güncelleme yapabilir miyiz kodda ? Teşekkür ederim

muratboz4206 · 3 Ocak 2021

Yukarıdaki makroyu çalıştırdıktan sonra aşağıdaki makroyu çalıştırınız. Ayrıca yukarıdaki kodda Set sablon = ThisWorkbook.Sheets("Şablon") satırından sonra kaynak.Select satırını eklerseniz. Kaynak sayfası dışındaki sayfada da makroyu çalıştırdığınızda doğru çalışacaktır. Aşağıdaki makroyu herhangi bir sayfadayken çalıştırabilirsiniz.

Kod:

Sub SutunAEDuzelt()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Kaynak" Or ws.Name = "Şablon" Then
            sonSatir = ws.Range("AE65536").End(xlUp).Row - 2
            For j = 3 To sonSatir
                If ws.Cells(j, 31).Value > 0 And (ws.Cells(j, 30).Value = 0 Or ws.Cells(j, 30).Value = "") Then
                    ws.Cells(j, 31).Value = ""
                End If
            Next j
        End If
    Next ws
    Msgbox "İşlem tamamlandı."

End Sub

hadromer · 4 Ocak 2021

muratboz4206' Alıntı:
Yukarıdaki makroyu çalıştırdıktan sonra aşağıdaki makroyu çalıştırınız. Ayrıca yukarıdaki kodda Set sablon = ThisWorkbook.Sheets("Şablon") satırından sonra kaynak.Select satırını eklerseniz. Kaynak sayfası dışındaki sayfada da makroyu çalıştırdığınızda doğru çalışacaktır. Aşağıdaki makroyu herhangi bir sayfadayken çalıştırabilirsiniz.

Kod:

Sub SutunAEDuzelt() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Kaynak" Or ws.Name = "Şablon" Then sonSatir = ws.Range("AE65536").End(xlUp).Row - 2 For j = 3 To sonSatir If ws.Cells(j, 31).Value > 0 And (ws.Cells(j, 30).Value = 0 Or ws.Cells(j, 30).Value = "") Then ws.Cells(j, 31).Value = "" End If Next j End If Next ws Msgbox "İşlem tamamlandı." End Sub

Çok teşekkür ederim, hepsi sorunsuz çalışıyor

hadromer · 4 Ocak 2021

@muratboz4206 Murat Bey, son yazdığımız kodu "AO" ve "AV" üstunlarını da dahil edebilir miyiz ? son kodda sadece AE sütunu için rica etmiştim sizden. Şimdi ao ve av sütunlarını da eklemem gerekti

AE için geçerli şartların aynıları AO ve AV içinde olması gerekiyor. sie de zahmet verdim kusura bakmayın.

muratboz4206 · 4 Ocak 2021

Deneyiniz, hangi sütunlarda düzeltme yaptığını aşağıda gösterdim. ilerde revize edecek olursanız aşağıdaki şekilde ekleme yapabilirsiniz.
Örnek: 31 AE sütunun, 30 AE nin yanındaki sütunu, 41 AO sütununun 30 AO sütununun yanındaki sütunun sütun numarasını belirtir. Sütun() formülünü herhangi bir sütundaki hücreye yazarsanız sütun numarasını verir.

Kod:

Sub SutunAEAOAVDuzelt()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Kaynak" Or ws.Name = "Şablon" Then
            sonSatir = ws.Range("AE65536").End(xlUp).Row - 2
            For j = 3 To sonSatir
            
                'AE sütununu düzeltir.
                If ws.Cells(j, 31).Value > 0 And (ws.Cells(j, 30).Value = 0 Or ws.Cells(j, 30).Value = "") Then
                    ws.Cells(j, 31).Value = ""
                End If
                
                'AO sütununu düzeltir.
                If ws.Cells(j, 41).Value > 0 And (ws.Cells(j, 40).Value = 0 Or ws.Cells(j, 40).Value = "") Then
                    ws.Cells(j, 41).Value = ""
                End If
                
                'AV sütununu düzeltir.
                If ws.Cells(j, 48).Value > 0 And (ws.Cells(j, 47).Value = 0 Or ws.Cells(j, 47).Value = "") Then
                    ws.Cells(j, 48).Value = ""
                End If
            Next j
        End If
    Next ws
    MsgBox "İşlem tamamlandı."

End Sub

muratboz4206 · 4 Ocak 2021

Ayrıca makroya gerek kalmadan
Şablon sayfasında
AE3 hücresine =EĞER(YADA(AD3=0;AD3="");0;T3)
AO3 hücresine =EĞER(YADA(AN3=0;AN3="");0;T3)
AV3 hücresine =EĞER(YADA(AU3=0;AU3="");0;T3) yazarak aşağıya doğru kopyalayarak revize edip SutunlariTasiveSayfalariOlustur() makrosunu çalıştırırsanız yine aynı sonuçları elde edersiniz.

hadromer · 4 Ocak 2021

Hocam harikasınız teşekkür ederim