Başlangıcı değişken olan değerleri, değişken adetlerde saydırma yapmak

[dogunay]

Merhabalar,

Başlangıcı değişken olan değerleri, değişken adetlerde saydırma yapmak istiyorum. Örnek ektedir. Yorum ve yardımlarınız için şimdiden teşekkürler.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Not: Kodlar Ofis 2003 ile düzenlendi. Farkı versiyon kullanıyorsanız ve satır sayısı yeterli gelmez ise kodlar içerisinde;
sonsatir = s1.Range("h65536").End(xlUp).Row + 1
Satırındaki 65536 sayısını 1048576 olarak değiştirebilirsiniz.

 

[dogunay]

Hocam tşk ederim. Denedim.

Toplamda 115bin satır yazması gerekiyor ancak bir yerde şişiyor ve döngü patlıyor. Bazen işlem tamam uyarısı verdiği halde herhangi bir veri yazmıyor. Kodu biraz daha kısaltıp döngüyü kolaylaştırmak için aklıma birşey geldi. Ek'i güncelleyerek, Sheet2 ye yazdım.

For için Başlangıç ve Bitiş değerleri vererek yaparsak ve her next ile 1-2 saniye kadar uyutursak nasıl olur?

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz? Makro çalışırken şişecek mi merak ettim.

Sub Duzenle()
    Dim s   As Double
    Dim i   As Long
    Dim j   As Long
    Dim k   As Long
    
    Application.ScreenUpdating = False
    
    Range("H2:J" & Rows.Count).ClearContents
    
    For i = 2 To Cells(Rows.Count, "a").End(3).Row
        j = Cells(Rows.Count, "H").End(3).Row + 1
        s = CLng(Cells(i, "A") & Application.WorksheetFunction.Rept("0", 10 - Len(Cells(i, "A"))))
        Cells(j, "H") = s
        Cells(j, "I") = Cells(i, "C")
        Cells(j, "J") = Cells(i, "D")
        If Cells(i, "B") > 1 Then
            k = j + Cells(i, "B") - 1
            Range("H" & j & ":H" & k).DataSeries Step:=1
            Range("I" & j & ":J" & k).FillDown
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "İŞLEM TAMAMLANMIŞTIR....", vbInformation, "N. YEŞERTENER"
    
End Sub

 

[mancubus]

AutoFill metodu ile alternatif...

Sub Rakamları_Doldur()

    With Sheet1 'sayfa indeksine göre numarayı değiştir veya Worksheets("Sheet1") vb kullan
        .Range("H1:J" & .Range("H" & .Rows.Count).End(xlUp).Row).Clear
        .Range("H1:J1") = Array("Numara", "Tanım1", "Tanım2")
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
            With .Range("H" & .Rows.Count).End(xlUp).Offset(1)
                .Value = (Sheet1.Range("A" & i)) * (Sheet1.Range("B" & i))
                .AutoFill .Resize(Sheet1.Range("B" & i), 1), xlFillSeries
                .Offset(, 1).Resize(Sheet1.Range("B" & i), 1) = Sheet1.Range("C" & i)
                .Offset(, 2).Resize(Sheet1.Range("B" & i), 1) = Sheet1.Range("D" & i)
            End With
        Next
    End With

End Sub