VBA farklı hücrelerden koşullu otomatik sıralama

[dilaverdemirer]

Resimde solda bulunan fiş numaralarının (başlangıç ve bitiş numaraları dahil) sağ tarafa aynı sırada hepsini yazdırmak istiyorum. Örnekte elle yazdım ancak makro ile otomatik sıralama lazım. Örnekte az miktarda.. bu bazen 100 lerce olabiliyor. Şimdiden yardımlarınız için teşekkür ediyorum .

 

[ÖmerFaruk]

Altın üye olarak dosyanızı ekleseniz, üzerinde çalışsak daha hızlı olacak.
Renklendirme de olacak mı onu da belirtirseniz iyi olur.

 

[dilaverdemirer]

Hocam işyeri bilgisayarı internet bağlantısı yok telefondan foruma giriyorum o yüzden bu şekilde yolladım.

 

[dilaverdemirer]

Hocam telden yapmaya çalıştım olmuştur inşallah.

 

[ÖmerFaruk]

Sub FişNo()
Dim i As Integer
Dim dizi()
Son = Range("B" & Rows.Count).End(3).Row ' B de alt tarafı boş kabul ettim
k = 4 ' F deki ilk satır. gerekiyorsa değiştirin
For i = 4 To Son 'B deki ilk satır farklıysa değiştirebilirsin.

    If Not IsNumeric(Range("C" & i)) Or Not IsNumeric(Range("D" & i)) Then GoTo Atla1
    If Range("C" & i) > Range("D" & i) Then GoTo Atla1
    For x = Range("C" & i) To Range("D" & i)
        Range("F" & k) = x
        k = k + 1
    Next x
Atla1:
Next i
End Sub

 

[YUSUF44]

Alternatif:

Sub doldur()
son = Cells(Rows.Count, "C").End(3).Row
eski = Cells(Rows.Count, "F").End(3).Row
Application.ScreenUpdating = False
    If eski > 2 Then
        Range("F4:H" & eski).Clear
    End If
    For kisi = 4 To son
        If IsNumeric(Cells(kisi, "C")) And IsNumeric(Cells(kisi, "D")) Then
            If Cells(kisi, "C") <= Cells(kisi, "D") Then
                For fis = Cells(kisi, "C") To Cells(kisi, "D")
                    yeni = Cells(Rows.Count, "F").End(3).Row + 1
                    Cells(yeni, "F") = fis
                Next
            End If
        End If
    Next
    enson = Cells(Rows.Count, "F").End(3).Row
    Range("F4:H" & enson).Borders.LineStyle = 1
    Range("G4:G" & enson).NumberFormat = "dd.mm.yyyy"
    Range("H4:H" & enson).NumberFormat = "#,##0.00"
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı!", vbInformation
End Sub