Tekrarlayan kod yardımı

[KRONX]

Merhaba,
Salon için seans listesi hazırlamam gerekiyor ama tekrarlayan noktalarda hata yapıyorum konuyla ilgili yardımcı olabilecek olan varsa şimdiden teşekkürler

İndir sorun

Dosyayı indir sorun

dosya.co

Yukarıdaki dosyada verilerin sadece bir kısmı var . Firmam her seans saati için üyelere 100 satırlık bir ekran açılmasını istiyor saat uzayınca işler karışıyor benim için bunu otomatikleştirmenin yolunu arıyorum.

Örneğin ilk sayfadaki A1
hücresindeki Fidan Ritim S1 numaralı salonu 1-3 arası kiralamış. bunun için benim yazmam gereken şey 100 kez ,Fidan Ritim-S1-001,100 kez ,Fidan Ritim-S1-002,ve 100 kez ,Fidan Ritim-S1-003, şeklinde olması gerekiyor nasıl yapmam gerekiyor

Yardımcı olacak herkese teşekkürler

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Y As Long
    Dim Z As Long, Say As Long
   
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("İstenilen ekran")
   
    S2.Range("A2:B" & S2.Rows.Count).ClearContents
   
    Veri = S1.Range("A2:D" & WorksheetFunction.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)).Value
   
    ReDim Liste(1 To S1.Rows.Count, 1 To 2)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            For Y = Veri(X, 3) To Veri(X, 4)
                For Z = 1 To 100
                    Say = Say + 1
                    Liste(Say, 1) = Say
                    Liste(Say, 2) = Veri(X, 1) & "-" & Veri(X, 2) & Format(Y, "-000")
                Next
            Next
        End If
    Next
   
    If Say > 0 Then S2.Range("A2").Resize(Say, 2) = Liste
   
    Set S1 = Nothing
    Set S2 = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[KRONX]

Deneyiniz.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Y As Long
    Dim Z As Long, Say As Long
  
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("İstenilen ekran")
  
    S2.Range("A2:B" & S2.Rows.Count).ClearContents
  
    Veri = S1.Range("A2:D" & WorksheetFunction.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)).Value
  
    ReDim Liste(1 To S1.Rows.Count, 1 To 2)
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            For Y = Veri(X, 3) To Veri(X, 4)
                For Z = 1 To 100
                    Say = Say + 1
                    Liste(Say, 1) = Say
                    Liste(Say, 2) = Veri(X, 1) & "-" & Veri(X, 2) & Format(Y, "-000")
                Next
            Next
        End If
    Next
  
    If Say > 0 Then S2.Range("A2").Resize(Say, 2) = Liste
  
    Set S1 = Nothing
    Set S2 = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Kod için Teşekkürler şahane oldu bir şey daha ekleyebilmemiz mümkün mü? yanlış yazmışım çünkü

Fidan Ritim-S1-001 değil de Fidan Ritim-S1-S001 olmalı ve bu G sutununa yazılmalı,

Yardımlarınız için teşekkürler

 

[Korhan Ayhan]

Merhaba,

Yanlış anlamazsanız birşey soracağım.

Konu açıyorsunuz. Örnek dosya ekliyorsunuz. Sonra diyorsunuz ki YANLIŞ yazmışım.

SORU sormak bu kadar zor mu?

Hem sizin zamanınız hem de bizlerin zamanı boşa gidiyor...