• Merhaba Ziyaretçi,
    Microsoft 365 Uygulamaları ile ilgili yeni haberler, dikkat çekici konular, ilgi ile takip edeceğiniz yazılar için.

    Abone Olun
  • ESTE - Microsoft Office Eğitimleri

    Yeni yıl Microsoft Office Eğitim planlarınız için bütçenizi oluşturmadan önce ESTE eğitim kalitesi ile tanışın. 🙌
    Kullanıcıların ihtiyacı olan yazılı materyal, dosya ve video kaynağı desteğimiz ile tüm ofis çalışanlarının iş süreçlerini rahatlatacak eğitimler planlayın. 🎯
    Microsoft Office eğitimlerimiz hakkında detaylı bilgi için bize ulaşın.

    👉 Microsoft Office Eğitim Talebi

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

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

hadromer

Yeni Üye
Katılım
3 Ocak 2021
Mesajlar
20
En iyi yanıt
0
Puanları
3
Yaş
33
Konum
Ankara
Ad Soyad
Ömer
Office Vers.
Office 2019 TR
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

Yeni Üye
Katılım
3 Eki 2020
Mesajlar
7
En iyi yanıt
2
Puanları
3
Yaş
40
Konum
Ankara
Ad Soyad
Murat Bozlağan
Office Vers.
Office 365 TR
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

Yeni Üye
Katılım
3 Ocak 2021
Mesajlar
20
En iyi yanıt
0
Puanları
3
Yaş
33
Konum
Ankara
Ad Soyad
Ömer
Office Vers.
Office 2019 TR
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 ederimresim_2021-01-03_232309.png
 

muratboz4206

Yeni Üye
Katılım
3 Eki 2020
Mesajlar
7
En iyi yanıt
2
Puanları
3
Yaş
40
Konum
Ankara
Ad Soyad
Murat Bozlağan
Office Vers.
Office 365 TR
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

Yeni Üye
Katılım
3 Ocak 2021
Mesajlar
20
En iyi yanıt
0
Puanları
3
Yaş
33
Konum
Ankara
Ad Soyad
Ömer
Office Vers.
Office 2019 TR
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

Yeni Üye
Katılım
3 Ocak 2021
Mesajlar
20
En iyi yanıt
0
Puanları
3
Yaş
33
Konum
Ankara
Ad Soyad
Ömer
Office Vers.
Office 2019 TR
@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

Yeni Üye
Katılım
3 Eki 2020
Mesajlar
7
En iyi yanıt
2
Puanları
3
Yaş
40
Konum
Ankara
Ad Soyad
Murat Bozlağan
Office Vers.
Office 365 TR
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

Yeni Üye
Katılım
3 Eki 2020
Mesajlar
7
En iyi yanıt
2
Puanları
3
Yaş
40
Konum
Ankara
Ad Soyad
Murat Bozlağan
Office Vers.
Office 365 TR
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

Yeni Üye
Katılım
3 Ocak 2021
Mesajlar
20
En iyi yanıt
0
Puanları
3
Yaş
33
Konum
Ankara
Ad Soyad
Ömer
Office Vers.
Office 2019 TR
Hocam harikasınız teşekkür ederim :)
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Üst Alt