Kombinasyon, 4 rakamlı

[1Al2Ver]

Merhaba,

Sayfa1 A1:A4 arasında, örneğin ; 0,1,2 ve 3 rakamı var,
Sayfa2 A2:A257 arasına, 4 harfli olmak üzere kombinasyon almak istiyorum,

0000
0001
0002
0003
0010
.....
0020
0021
0022
0023
.....
.....
3333

şeklinde gitmektedir,

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Çözüm yada öneri rica ediyorum,

Teşekkür ederim.

 

[Ömer]

Merhaba,

Çok fazla işlevsel olmadı, umarım işinize yarar.

Sub GrupluPermutasyon()
 
Dim sat As Long, sut As Integer
Dim ilk As Double, son As Double
Dim S1 As Worksheet
Dim a As Byte, b As Byte, c As Byte, d As Byte
 
Set S1 = Sheets("Sayfa1")
Application.ScreenUpdating = False
 
Sheets("Sayfa2").Select
With Cells
  .ClearContents
  .NumberFormat = "@"
  .EntireColumn.AutoFit
  .HorizontalAlignment = xlCenter
End With
 
Range("A1") = "Kod"
ilk = S1.Range("A1")
son = S1.Range("A" & S1.Cells(Rows.Count, "A").End(xlUp).Row)
sat = 2: sut = 1
 
    For a = ilk To son
      For b = ilk To son
        For c = ilk To son
          For d = ilk To son
            Cells(sat, sut) = a & b & c & d
            sat = sat + 1
            If sat = Rows.Count Then sat = 2: sut = sut _
                    + 1: Cells(1, sut) = "Kod"
          Next d
        Next c
      Next b
    Next a
 
Application.ScreenUpdating = True
End Sub

.

 

[1Al2Ver]

Merhaba,

Çok fazla işlevsel olmadı, umarım işinize yarar.

Sub GrupluPermutasyon()
 
Dim sat As Long, sut As Integer
Dim ilk As Double, son As Double
Dim S1 As Worksheet
Dim a As Byte, b As Byte, c As Byte, d As Byte
 
Set S1 = Sheets("Sayfa1")
Application.ScreenUpdating = False
 
Sheets("Sayfa2").Select
With Cells
  .ClearContents
  .NumberFormat = "@"
  .EntireColumn.AutoFit
  .HorizontalAlignment = xlCenter
End With
 
Range("A1") = "Kod"
ilk = S1.Range("A1")
son = S1.Range("A" & S1.Cells(Rows.Count, "A").End(xlUp).Row)
sat = 2: sut = 1
 
    For a = ilk To son
      For b = ilk To son
        For c = ilk To son
          For d = ilk To son
            Cells(sat, sut) = a & b & c & d
            sat = sat + 1
            If sat = Rows.Count Then sat = 2: sut = sut _
                    + 1: Cells(1, sut) = "Kod"
          Next d
        Next c
      Next b
    Next a
 
Application.ScreenUpdating = True
End Sub

.

Merhaba,

Zahmetiniz için teşekkür ederim,

Makro çalıştırıldığında "tip uyuşmazlığı" mesajı aldım ve sayfa1 A1 hücresine "kod" yazısı geldi, uygun olduğunuzda gözden geçirebilir seniz memnun olurum,

Teşekkür ederim.

 

[Ömer]

Kodları sayfa bölümüne değil Module yerleştirin.

.

 

[1Al2Ver]

Kodları sayfa bölümüne değil Module yerleştirin.

.

Tekrar merhaba Ömer bey,

Teşekkür ederim, dikkatimden kaçmış,

Saygılarımla.