istenilen harf kadar yazdıramama

[mersilen]

merhabalar

Tablodaki harfleri sayısı kadar yeni tabloya yazdırmaya çalışıyorum ama sonuç istediğim gibi olmuyor

Private Sub CommandButton1_Click()
Dim hucre As Range
Dim hucre1 As Range

For Each hucre In Range("k5:k14")
If hucre = "" Then
For Each hucre1 In Range("a1:d1")
Range("a3") = WorksheetFunction.CountIf(Range("k5:k14"), hucre1)
Range("a4") = Cells(hucre1.Row + 1, hucre1.Column).Value
If hucre = "" And hucre1 <> "" And WorksheetFunction.CountIf(Range("k5:k14"), hucre1.Value) <= Cells(hucre1.Row + 1, hucre1.Column).Value Then
hucre = hucre1
End If
Next
End If
Next
End Sub

Amaç:K5:k14 arasına A1: D1 arasındaki harfleri altlarındaki (A2: D2) rakamlar kadar doldurmak

sorun:WorksheetFunction.CountIf(Range("k5:k14"), hucre1.Value) <= Cells(hucre1.Row + 1, hucre1.Column).Value
formülü hep bir fazla yazıyor

 

[mersilen]

Tekrar merhabalar

If (WorksheetFunction.CountIf(Range("k5:k14"), hucre1.Value) <= (Cells(hucre1.Row + 1, hucre1.Column).Value) - 1) And hucre = "" And hucre1 <> "" Then
hucre = hucre1

koddaki düzeltmeyle istediğim sonucu aldım,
ama sorunun ne olduğunu anlayamadım,

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki koduda kullanabilirsiniz.

Sub nöbet()
    Dim X, Y, Satır
    
    Range("K5:K14") = ""
    Satır = 5
    
    For X = 1 To 4
        If Cells(1, X) <> "" Then
            For Y = 1 To Cells(2, X)
                Cells(Satır, "K") = Cells(1, X)
                Satır = Satır + 1
            Next
        End If
    Next
End Sub

 

[mersilen]

Korhan hocam sizin kod K5:K14 tamamı boşsa oluyor ama arada tek dolular varken olmuyor
kodu ben

Private Sub CommandButton1_Click()
X = 5
Y = 11
a = 1
b = 1

For X = 5 To 14
If Cells(X, Y) = "" Then

For b = 1 To 4
Range("a3") = WorksheetFunction.CountIf(Range("k5:k14"), Cells(a, b).Value)
Range("a4") = (Cells(a + 1, b).Value) - 1
If (WorksheetFunction.CountIf(Range("k5:k14"), Cells(a, b).Value) <= (Cells(a + 1, b).Value) - 1) And Cells(X, Y) = "" And Cells(a, b) <> "" Then
Cells(X, Y) = Cells(a, b)
End If
Next b

End If
Next X
End Sub

şeklinde düzenledim ve oldu
şimdi K5:K14 deki harfleri yazarken aralarına en az 3 birim mesafe koydurmak istiyorum, bu şekilde kodu düzenledim, yalnız arada boş bırakıyor, bunu önlemek için döngüyü nasıl düzenlemeliyim

'Option Explicit
Private Sub CommandButton1_Click()
X = 5
Y = 11
a = 1
b = 1

For X = 5 To 14
If Cells(X, Y) = "" Then

For b = 1 To 4
Range("a3") = WorksheetFunction.CountIf(Range("k5:k14"), Cells(a, b).Value)
Range("a4") = (Cells(a + 1, b).Value) - 1
If (WorksheetFunction.CountIf(Range(Cells(X - 3, Y), Cells(X + 3, Y)), Cells(a, b).Value)) < 1 And (WorksheetFunction.CountIf(Range("k5:k14"), Cells(a, b).Value) <= (Cells(a + 1, b).Value) - 1) And Cells(X, Y) = "" And Cells(a, b) <> "" Then
Cells(X, Y) = Cells(a, b)
End If
Next b

End If
Next X
End Sub