Bir Sütundaki Verileri Yanındaki Sütunlara Dağıt - Microsoft Excel

A sütunundaki toplam veri sayısı, verilen sütuna bölünüyor ve bu sonuç tam sayı olacak şekilde yukarı yuvarlanıyor. Böylelikle son sütun verilen sayıdan düşük olsa bile sıkıntı çıkmıyor. Her sütuna düşecek veri sayısını belirledikten sonra A sütunundaki veriler sırayla yanındaki sütunlara dağıtılıyor.

Kodu aşağıdaki bilgilere uygun olarak çalıştırın. En temizi boş bir sayfada çalıştırmak. Bir yerden sonra ayarlamalar çok sıkıcı olmaya başladığından dolayı bu ayarları yapmadım. Yaparsam güncellerim.

• Veriler sütunun başından başlasın. Eğer A sütunundaysa A1’den, B sütunuysa B1’den vs.
• Sütun başlığı olmasın. Olması kodun çalışmasına engel değil ama kafa karıştırabilir.
• Sütunda ilgili veriler dışında hiçbir şey olmasın. Bu da kodun çalışmasına engel değil ama son sütunda boşluklar olursa ve verilen alandan sonra da devam eden veriler varsa onları da ekliyor, gereksiz fazlalık oluyor.

Option Explicit

Sub BirSutundakiVerileriSutunlaraDagit(alan As Range, sutunSayisi As Integer)
    
    Dim i                        As Long
    Dim mesaj                    As Variant
    Dim alanSutunAdi             As String
    Dim hedefSutunlar            As Range
    Dim sutunBasinaEklenecekVeri As Long
        
    alanSutunAdi = Left(alan.Address(0, 0), 1)
    
    If alan.Columns.Count > 1 Then Exit Sub
        
    sutunBasinaEklenecekVeri = _
        WorksheetFunction.RoundUp(alan.Rows.Count / sutunSayisi, 0)
    
    Set hedefSutunlar = _
        Columns(alan.Column + 1).Resize(, sutunSayisi).EntireColumn
    
    If WorksheetFunction.CountA(hedefSutunlar) <> 0 Then
        mesaj = MsgBox(hedefSutunlar.Address & _
                    " sütunları içinde veri tespit edildi ve silinecek. " & _
                    "Devam edilsin mi?", _
                    vbYesNo, _
                    "UYARI")
                    
        If mesaj = vbYes Then
            GoTo devam
        Else
            MsgBox "İşlem iptal edildi. Herhangi bir işlem yapılmadı."
            Exit Sub
        End If
    End If


devam:
    hedefSutunlar.Clear
    
    For i = 1 To sutunSayisi
        Range(alanSutunAdi & "1:" & alanSutunAdi & sutunBasinaEklenecekVeri).Offset(0, i).Value = _
        Range(alanSutunAdi & ((i - 1) * sutunBasinaEklenecekVeri + 1) & ":" & alanSutunAdi & i * sutunBasinaEklenecekVeri).Value
    Next
End Sub

Sub Kullan()
    BirSutundakiVerileriSutunlaraDagit Range("F1:F1000"), 5
End Sub

Option Explicit

Sub BirSutundakiVerileriSutunlaraDagit(alan As Range, sutunSayisi As Integer)
    
    '--------------------------------------------------
    'Döngü için kullanılacak.
    '--------------------------------------------------
    Dim i As Long
    
    '--------------------------------------------------
    'Eğer etkilenecek sütunda veri varsa
    'değişiklik yapılıp yapılmayacağını MsgBox
    'ile soracağız, cevabı da bu değişken
    'aracılığı ile alacağız.
    '--------------------------------------------------
    Dim mesaj As Variant
    
    '--------------------------------------------------
    'Sub yordamda parametre olarak verilen
    'alan isimli Range tipli değişkenin
    'sütun adını öğrenmek için kullanacağız.
    '(A, B, K, M, AC gibi sütun adları çıkacak.)
    '--------------------------------------------------
    Dim alanSutunAdi As String
    
    '--------------------------------------------------
    'Verilerin ekleneceği sütunlarla ilgili
    'işlem yapacağız, bu sütunlara da
    'bu değişkenle müdahale edeceğiz.
    '--------------------------------------------------
    Dim hedefSutunlar As Range
    
    '--------------------------------------------------
    'Alandaki verileri sütunlara dağıtmak için
    'hesap yapacağız ve ona göre verileri böleceğiz.
    'Bu hesabın sonucunu da bu değişkene aktaracağız.
    '--------------------------------------------------
    Dim sutunBasinaEklenecekVeri As Long
        
    '--------------------------------------------------
    'Eğer verilen alanın sütun sayısı
    '1'den fazlaysa kod çalışmasın.
    '--------------------------------------------------
    If alan.Columns.Count > 1 Then Exit Sub
    
    '--------------------------------------------------
    'Verilen alanın sütun ismini öğrendik.
    'Biz zaten tek sütun için çalıştığımızdan
    'alanın tek bir sütunu ve dolayısıyla
    'tek bir adı olacak.
    '--------------------------------------------------
    alanSutunAdi = Left(alan.Address(0, 0), 1)
    
    '--------------------------------------------------
    'Alandaki toplam veri sayısını,
    'verdiğimiz sütun sayısına bölüyoruz.
    'Bu sayı küsüratlı çıkarsa üste yuvarlıyoruz.
    'Böylelikle eksik veri gelmesini önlemiş oluyoruz.
    '
    'Sonuç olarak da her sütuna kaç veri
    'düşeceğini belirlemiş oluyoruz.
    '--------------------------------------------------
    sutunBasinaEklenecekVeri = _
        WorksheetFunction.RoundUp(alan.Rows.Count / sutunSayisi, 0)
    
    '--------------------------------------------------
    'Sütunlara dağıtma işlemi parametrede verilen alanın
    'bir sağındaki sütundan itibaren başlayacak. Buna
    'göre etkilenen sütunlar üzerinde kontrol yapmak için
    'etkilenecek bu alanları dinamik olarak belirliyoruz.
    '--------------------------------------------------
    Set hedefSutunlar = _
        Columns(alan.Column + 1).Resize(, sutunSayisi).EntireColumn
    
    '--------------------------------------------------
    'Eğer etkilenecek sütunlarda veri varsa silinip
    'silinmeyeceğini soruyoruz. Eğer evet cevabı
    'gelirse eski veriler silinecek ve yerine
    'yenileri yazılacak. Hayır cevabı gelirse
    'hiçbir şey yapılmayacak.
    '--------------------------------------------------
    If WorksheetFunction.CountA(hedefSutunlar) <> 0 Then
        
        '--------------------------------------------------
        'Gösterilecek mesajı ayarladık.
        '--------------------------------------------------
        mesaj = MsgBox(hedefSutunlar.Address & _
                    " sütunları içinde veri tespit edildi ve silinecek. " & _
                    "Devam edilsin mi?", _
                    vbYesNo, _
                    "UYARI")
                    
        If mesaj = vbYes Then
            '--------------------------------------------------
            'Eğer evet cevabı gelirse bu noktadan bir zıplama
            'yapacak ve kod "devam" isimli referans noktasından
            'itibaren çalışmaya devam edecek.
            '--------------------------------------------------
            GoTo devam
        Else
            
            '--------------------------------------------------
            'Hayır cevabı gelmişse bir değişiklik yapılmadığı
            'ile ilgili mesaj gelecek ve yordamdan çıkılacak.
            '--------------------------------------------------
            MsgBox "İşlem iptal edildi. Herhangi bir işlem yapılmadı."
            Exit Sub
        End If
    End If

devam:
    
    '--------------------------------------------------
    'Etkilenecek sütunları veri karışıklığını
    'önlemek amacıyla temizledik ve kullanıma
    'hazır hale getirdik.
    '--------------------------------------------------
    hedefSutunlar.Clear
    
    '--------------------------------------------------
    'Parametrede verilen sütun sayısı
    'kadar işlem yaptırıyoruz.
    '--------------------------------------------------
    For i = 1 To sutunSayisi
        
        '--------------------------------------------------
        'Olayı kısaca şu:
        'Etkilenecek sütunu ve ana veride eklenecek
        'kısmı dinamik olarak seçiyor ve ekliyor.
        '
        'Eşitliğin Sol Tarafı:
        'Ana verinin sütununun 1 sağından itibaren sütun sütun
        'kaydırılıyor ve ekleme sayısı kadar alanın değeri için
        'atama yapılıyor.
        '
        'Eşitliğin Sağ Tarafı:
        'Hesaplanan ekleme sayısı kadar satır grup grup,
        've yukarıdan aşağıya doğru olacak şekilde seçiliyor.
        'Sol tarafta belirlenen ilgili sütuna aktarılıyor.
        '--------------------------------------------------
        Range(alanSutunAdi & "1:" & alanSutunAdi & sutunBasinaEklenecekVeri).Offset(0, i).Value = _
        Range(alanSutunAdi & ((i - 1) * sutunBasinaEklenecekVeri + 1) & ":" & alanSutunAdi & i * sutunBasinaEklenecekVeri).Value
    Next
End Sub

Sub Kullan()
    
    '--------------------------------------------------
    'Parametre olunca parametre bilgisi de vermemiz gerektiğinden
    'doğrudan kullanamadık. Başka bir yordamda parametre bilgileri
    'verip bu yordamı çalıştırdığımızda işlem gerçekleşiyor.
    'F1:F1000 alanı 5 sütuna bölünüyor.
    '--------------------------------------------------
    BirSutundakiVerileriSutunlaraDagit Range("F1:F1000"), 5
End Sub