Makro İle İstenilen Aralığı Saydırmak

[ormann]

İyi günler;
Ekli dosyada M-1 sayfasında say butonuna bastığımda Userform3 açılıyor.Açılan Userform da Textbox1'e başlangıç sayısını; Textbox2'ye bitiş sayısını yazıp Say butonuna bastığımda M-1 sayfasında A10:A59 hücre aralığına Başlangıç ve bitiş sayılarını yazdırabilir miyiz. ?.Eğer Textbox3ê de yazılmasını istemediğimiz sayıları yazdığım zaman (aralara virgül koyarak )makro bu sayıları yazmayacak.Örneğin
Başlangıç Sayısı:15
Bitiş Sayısı :25
Atlanacak :18,20,24
A1:A59 hücresine sırası ile yazılacak sayılar: 15,16,17,19,21,22,23,25
Yardımlarınızı bekliyorum.Saygılar

İndir Örnek

Dosyayı indir Örnek

dosya.co

 

[Haluk]

Private Sub CommandButton1_Click()
    'Haluk - 02/12/2019
    'sa4truss@gmail.com
    Dim intStart As Integer, intEnd As Integer
    Dim i As Integer, j As Integer
    Dim Dict As Object
    
    Range("A10:A59") = ""
    intStart = TextBox1
    intEnd = TextBox2
    
    Set Dict = CreateObject("Scripting.Dictionary")
    
    For i = intStart To intEnd
        Key = "Start" & i
        Value = i
        If Not Dict.Exists(Key) Then
            Dict.Add Key, Value
        End If
    Next
    myArr = Split(TextBox3, ",")
    
    For j = LBound(myArr) To UBound(myArr)
        Key = "Start" & Trim(myArr(j))
        If Dict.Exists(Key) Then Dict.Remove Key
    Next
  
    Range("A10").Resize(Dict.Count) = Application.Transpose(Dict.items)
End Sub

.

 

[ormann]

Haluk bey çok teşekkür ederim.Userformdaki veriler boş olduğu zaman botona bastığımda

intStart = TextBox1

ilgiil makroda hata veriyor. Ayrıca Userformdan çıkıp tekrar girdiğimde önceki girilen verilerin kaybolmaması için ne yapmalıyız ?

 

[Haluk]

TextBox'lar boşken niye butona basıyorsunuz, onu anlamadım....

.

 

[ormann]

Bazen yanlışlıkla olabiliyor. Haluk bey

 

[Haluk]

Peki, o zaman bunu kullanın....

Private Sub CommandButton1_Click()
    'Haluk - 02/12/2019
    'sa4truss@gmail.com
    Dim intStart As Integer, intEnd As Integer
    Dim i As Integer, j As Integer
    Dim Dict As Object
    
    Range("A10:A59") = ""
    
    intStart = Val(TextBox1)
    intEnd = Val(TextBox2)
    
    If Not (intStart > 0 And intEnd > 0) Then Exit Sub

    Set Dict = CreateObject("Scripting.Dictionary")
    
    For i = intStart To intEnd
        Key = "Start" & i
        Value = i
        If Not Dict.Exists(Key) Then Dict.Add Key, Value
    Next
    
    myArr = Split(TextBox3, ",")
    
    For j = LBound(myArr) To UBound(myArr)
        Key = "Start" & Trim(myArr(j))
        If Dict.Exists(Key) Then Dict.Remove Key
    Next
  
    Range("A10").Resize(Dict.Count) = Application.Transpose(Dict.items)
End Sub

.

 

[ormann]

Haluk bey çok teşekkür ederim. M-1 sayfasını A10:A59 hücre aralığını nasıl sınırlandırma yapabiliriz. Yani Başlangıç tarihini 10 bitiş tarihini ise 65 yazdığımızda M-1 sayfasında son satır A59 'a kadar yazacak.A59 satırını geçmeyecek.

 

[Haluk]

Aşağıdaki istediğinizi karşılıyor mu?

Private Sub CommandButton1_Click()
    'Haluk - 02/12/2019
    'sa4truss@gmail.com
    Dim intStart As Integer, intEnd As Integer
    Dim i As Integer, j As Integer
    Dim Dict As Object
    
    Range("A10:A59") = ""
    
    intStart = Val(TextBox1)
    intEnd = Val(TextBox2)
    
    If Not (intStart > 0 And intEnd > 0) Then Exit Sub

    Set Dict = CreateObject("Scripting.Dictionary")
    
    For i = intStart To intEnd
        Key = "Start" & i
        Value = i
        If Not Dict.Exists(Key) Then Dict.Add Key, Value
    Next
    
    myArr = Split(TextBox3, ",")
    
    For j = LBound(myArr) To UBound(myArr)
        Key = "Start" & Trim(myArr(j))
        If Dict.Exists(Key) Then Dict.Remove Key
    Next
  
    For i = 0 To 49
        If i >= Dict.Count Then
            Exit For
        Else
            Range("A" & i + 10) = Dict.Items()(i)
        End If
    Next
End Sub

.

 

[ormann]

Haluk bey çok teşekkür ederim.Tam istediğim şekilde çalışıyor

 

[ormann]

Haluk hocam günaydın. Son olarak ekli dosyada Textbox1'e başlangıç tarihini,TextBox2'ye bitiş tarihini,Textbox3'e ise yazılmasını istemediğimiz sayıları yazdığımızda say butonuna bastığımızda kodlar gayet güzel çalışıyor.Benim yapmak istediğim TextBox2'ye bitiş tarihini yazıp,araya virgül koyduğumuzda devamını atlamalı olarak yazdırabilirmiyiz ?.
Örneğin :
Başlangıç sayısı :1
Bitiş Sayısı :10,15,17,20,50
Yazılmasını istemediğimiz sayı :5
A10:A59 hücre aralığına saydırılacak sonuç şu şekilde olacak: 1,2,3,4,6,7,8,9,10,15,17,20,50

 

[Haluk]

TextBox1'e : 1

TextBox2'e : 10,15,17,20,50

TextBox3'e : 5

yazıp, aşağıdaki kodu çalıştırın ....

Private Sub CommandButton1_Click()
    'Haluk - 03/12/2019
    'sa4truss@gmail.com
    Dim intStart As Integer, intEnd As Integer
    Dim i As Integer, j As Integer
    Dim Dict As Object
   
    Range("A10:A59") = ""
   
    intStart = Val(TextBox1)
   
    If Not (Len(TextBox1) > 0 And Len(TextBox2) > 0) Then Exit Sub

    Set Dict = CreateObject("Scripting.Dictionary")
   
    myArr = Split(TextBox2, ",")
   
    intEnd = myArr(0)
   
    For i = intStart To intEnd
        Key = "Start" & i
        Value = i
        If Not Dict.Exists(Key) Then Dict.Add Key, Value
    Next
   
    myArr2 = Split(TextBox3, ",")
   
    For j = LBound(myArr2) To UBound(myArr2)
        Key = "Start" & Trim(myArr2(j))
        If Dict.Exists(Key) Then Dict.Remove Key
    Next
   
    For i = 0 To Dict.Count - 1
        Range("A" & i + 10) = Dict.Items()(i)
    Next
  
    For j = 1 To UBound(myArr)
        Range("A" & i + 9 + j) = myArr(j)
    Next
End Sub

.