Ardışık sayıları gruplama

cengiz123 · 6 Aralık 2017

Merhabalar
Bir konuda yardımınıza ihtiyacım var.

İkinci,üçüncü,dördüncü satırda bazı ardışık sayılar var.
2.satırda hücreler sırasıyla
33 34 35 37 38 39 40 44 47 48 49 50

3.satırda hücreler sırasıyla
104 105 106 110 111 112

4.satırda hücreler sırasıyla
243 244 245 246 249 250 251 255 256

İstediğim sonuç ise;
33den35e_37den40a_44_47den50ye

104den106ya_110dan112ye

243den246ya_249dan251e_255_256

Bunun gibi 20 satıra kadar uzanabilir.
Kural ise:
3 ve üzeri ardışık sayıda örneğin 33den 38e gibi
1 ve 2 ardışık sayı için örneğin 33 37 38 için 33_37_38

Yardımlarınızı rica ederim

Asri · 7 Aralık 2017

Bu rakamların her bir satırında, her bir rakam ayrı bir hücrede mi? Aynı hücre içinde mi?

den, dan önemli mi?

askm · 7 Aralık 2017

Sorunuzu örnek dosya ile anlatırsanız daha çabuk çözüm alırsınız.

Asri · 7 Aralık 2017

Kontrol ediniz.
Den, dan, e,a yerine başka bir şey kullanın

https://www.dosyaupload.com/586x

Sayılar B2 den başlamalı, sonucları her bir satırda A ya yazılmaktadır.

Not:Kod günceldir, dosya değil. Kodu dosyaya yapıştırın.

Kod:

Sub ardisik_birlestir()
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   Range("A2:A" & sonsatir).Clear
   sonsatir = Cells(Rows.Count, "B").End(3).Row
   
   For i = 2 To sonsatir
     sonsutun = Cells(i, Columns.Count).End(xlToLeft).Column
     veri = ""
     For k = 2 To sonsutun
        veri = veri & Cells(i, k).Value & " "
     Next k
     veri = Mid(veri, 1, Len(veri) - 1)
     liste = Split(veri, " ")
     listesay = UBound(liste)
     ekle = False
     sonuc = ""
     eskisayi = ""
     For j = LBound(liste) To UBound(liste)
        sayi1 = 0
        sayi2 = 0
        sayi3 = 0
        sayi1 = 0 + liste(j)
        If j + 1 <= listesay And ekle = False Then
           sayi2 = 0 + liste(j + 1)
        Else

        End If
        
        If j + 2 <= listesay And ekle = False Then
           sayi3 = 0 + liste(j + 2)
        Else
        
        End If
        
        If sayi1 + 1 = sayi2 And sayi2 + 1 = sayi3 And ekle = False Then
           ilksayi = sayi1
           eskisayi = sayi3
     
           ekle = True
           If j = listesay Then
           ElseIf j + 2 = listesay Then
             j = j + 2
           Else
             j = j + 2
             GoTo son
           End If
        End If
        
        If sayi1 + 1 = sayi2 And sayi2 + 1 <> sayi3 And ekle = False Then
           eskisayi = ""
           If sonuc = "" Then
              sonuc = sayi1 & "_"
           Else
              sonuc = sonuc & sayi1 & "_"
           End If
           ekle = False
           GoTo son
        End If
        
        If sayi1 + 1 <> sayi2 And ekle = False Then
           eskisayi = ""
           If sonuc = "" Then
              sonuc = sayi1 & "_"
           Else
              sonuc = sonuc & sayi1 & "_"
           End If
           ekle = False
           GoTo son
        End If
        
        If ekle And eskisayi + 1 = sayi1 Then
           eskisayi = sayi1
           If j = listesay Then
           Else
             GoTo son
           End If
        End If
        
        If ekle And sonsayi + 1 <> sayi1 Then
           If sonuc = "" Then
              sonuc = ilksayi & "den" & eskisayi & "e_"
           Else
              sonuc = sonuc & ilksayi & "den" & eskisayi & "e_"
           End If
           
           ekle = False
           If j <> listesay Then j = j - 1
           [COLOR=Red]If j = listesay And ekle = False Then j = j - 1[/COLOR]
        End If
        
        eksisayi = sayi1
son:
     Next
     sonharf = Right(sonuc, 1)
     If sonharf = "_" Then
       sonuc = Left(sonuc, Len(sonuc) - 1)
     End If
     satir = satir + 1
     Cells(i, 1).Value = sonuc
   Next i
  
End Sub

cengiz123 · 7 Aralık 2017

asri hocam, kodu denedim. maalesef çalışmadı..
sadece ilk 33,104,243 değerlerini B sütununa atıyor.

Asri · 7 Aralık 2017

cengiz123' Alıntı:
asri hocam, kodu denedim. maalesef çalışmadı..
sadece ilk 33,104,243 değerlerini B sütununa atıyor.

@askm nin dediği noktaya geldik.

Örnek dosya yükleyiniz

cengiz123 · 7 Aralık 2017

https://www.dosyaupload.com/9kcY

dosyayı yükledim. N sütüununda olması gerekenleri yazdım.

Asri · 7 Aralık 2017

cengiz123' Alıntı:
https://www.dosyaupload.com/9kcY

dosyayı yükledim. N sütüununda olması gerekenleri yazdım.

Ben tüm sayılar aynı hücrede arada boşluk var olarak yazmıştım.
Kod güncellendi. Dosya eklendi.

cengiz123 · 8 Aralık 2017

Asri hocam elinize sağlık. Ben baya uğraştım ama yapamamıştım. Kodu görünce niye yapamadığımı
Çok teşekkürler

cengiz123 · 8 Aralık 2017

Asri hocam merhaba
601 605 607 608 609 611 612 613 617
gibi bir dizim olduğunda 617 yi gruplamada göstermiyor.
hata olabilir mi kodda?

Asri · 9 Aralık 2017

cengiz123' Alıntı:
Asri hocam merhaba
601 605 607 608 609 611 612 613 617
gibi bir dizim olduğunda 617 yi gruplamada göstermiyor.
hata olabilir mi kodda?

mümkündür, karışık bir gruplama sistemi olduğu için bazı varyasyonları tanımayabilir verdiğiniz örneklerde sorun olmamıştı.
Test etmekte yarar var. En başta bir sayı sonra iki ardışık, ortada bir sayı sonra iki ardışık, sonda bir sayı sonra iki ardışık gibi test edin. Sorunlu olnaları bildirin düzeltmeye çalışalım.

Asri · 9 Aralık 2017

cengiz123' Alıntı:
Asri hocam merhaba
601 605 607 608 609 611 612 613 617
gibi bir dizim olduğunda 617 yi gruplamada göstermiyor.
hata olabilir mi kodda?

Sondaki tek sayı için güncelleme yapıldı. Testleriniz yapınız.

cengiz123 · 10 Aralık 2017

merhaba asri hocam,
cevabınız için teşekkür ederim.
aşağıdaki durumlarda son sayıyı tekrarlamaktadır. yardımcı olabilir misiniz
800 801 802 808 811 816 820 821 822 823 824 825
600 601 602 603 604 608 609 610 611 612 615 616 617 618 619
501 502 503
500 506 511 512 513
503 504 505 506

cengiz123 · 11 Aralık 2017

Asri hocam konu hakkında bir çözüm bulabildiniz mı?

systran · 11 Aralık 2017

şu kodları dener misin? kırmızı olan yorum satırlarını sırası ile birinin yorumunu kaldırıp diğerlerini yorum haline dönüştür. aralıkları istediği gibi çıkar ması lazım! Debug.print yöntemi kullanılmıştır, VBA editördeki immediate pencerisinin açık olduğuna emin olun.

Kod:

Sub test()
Dim dizi() As String
Dim dizik(10, 1) As Integer
Dim tmpStr As String
[COLOR="Red"]'tmpStr = "800 801 802 808 816 820 821 822 823"
'tmpStr = "800 802 808 816 820 821 822 823 888"
'tmpStr = "800 801 802 803 804 805 806 807 808"
'tmpStr = "800 801 802 803 804 805 806 807 808"
'tmpStr = "800 801 802 808 811 816 820 821 822 823 824 825"
tmpStr = "600 601 602 603 604 608 609 610 611 612 615 616 617 618 619"
'tmpStr = "501 502 503"
'tmpStr = "500 506 511 512 513"
'tmpStr = "503 504 505 506"[/COLOR]

dizi = Split(tmpStr, " ")
basla = 0
bitis = 1
uzunluk = UBound(dizi)
ptr = 0
say1 = dizi(basla)
say2 = dizi(bitis)
For i = 1 To uzunluk
    fark = Val(dizi(bitis)) - Val(dizi(bitis - 1))
    If fark = 1 Then                'aradaki fark 1 ise bitis göstergesini 1 arttır
        bitis = bitis + 1
    ElseIf fark > 1 Then            'aradaki fark 1 den farklı ise, başlangıç ve bitiş konumlarını kayıt et.
        dizik(ptr, 0) = basla
        dizik(ptr, 1) = bitis - 1
        ptr = ptr + 1
        basla = bitis
        bitis = bitis + 1
    End If
    
    If i = uzunluk Then 'son elemana gelinmiş ise
        dizik(ptr, 0) = basla
        dizik(ptr, 1) = bitis - 1
    End If
    
Next i
MsgBox (ptr + 1) & " Aralık bulundu!"
For i = 0 To ptr
    Debug.Print dizi(dizik(i, 0)) & "<-->" & dizi(dizik(i, 1))
Next i
End Sub

cengiz123 · 11 Aralık 2017

Systran hocam,
Yardımınız için teşekkürler.
Yalnız veriler değişken. Ben sadece yukarıdaki sayıları örnek olsun diye vermiştim

systran · 11 Aralık 2017

kodu denediniz mi? aralığı doğru bulma adına sizin verdiğiniz örnek dizileri deneme amaçlı elle girdim.

cengiz123 · 11 Aralık 2017

Evet denedim systran hocam. Aslında asri hocanın kodu çalışıyor ama son ekleme ile kod tekrarı var. O çözülse konu hal olacak

Asri · 11 Aralık 2017

Belirsizlik hoşuma gitmedi,
yeniden kodladım, bu şekilde deneyiniz.
800den802 e si yok ama olur mu bu şekilde

Bu gruplama içime sindi, sorun olacağını düşünmüyorum.

800den802_808_811_816_820den825
600den604_608den612_615den619
501den503 500_506_511den513
503den506

Sayıların Sayfa1 de ve B kolonundan başladığı varsayılmıştır.

Kod:

Sub ardisik_birlestir()
 Application.DisplayAlerts = False
    If WorksheetExists("Gecicixxxxx") Then Sheets("Gecicixxxxx").Delete
    Set newsh = Sheets.Add(After:=Sheets(Sheets.Count))
    newsh.Name = "Gecicixxxxx"
  
    Sheets("Sayfa1").Select
    Cells.Select
    Selection.Copy
    Sheets("Gecicixxxxx").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("B9").Select
    Columns("A:A").Delete
    
    'Tire ekle
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = 1 To sonsatir
      sonsutun = Cells(i, Columns.Count).End(xlToLeft).Column
      say = 0
      For j = sonsutun To 1 Step -1
         sayi = 0 + Cells(i, j).Value
         If j = sonsutun Then
            eskisayi = sayi
         ElseIf eskisayi - 1 <> sayi Then
           If say = 2 Then
            Cells(i, j + 2).Select
            Application.CutCopyMode = False
            Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(i, j + 2).Value = "_"
            j = j + 1
            eskisayi = Cells(i, j).Value
            say = 0
            GoTo son
           Else
            Cells(i, j + 1).Select
            Application.CutCopyMode = False
            Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(i, j + 1).Value = "_"
           End If
           say = 0
         End If
         say = say + 1
         eskisayi = sayi
son:
      Next j
     
      If say = 2 Then
        Cells(i, 2).Select
        Application.CutCopyMode = False
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Cells(i, 2).Value = "_"
        say = 0
      End If
      sonsutun = Cells(i, Columns.Count).End(xlToLeft).Column + 1
      Cells(i, sonsutun).Value = "_"
    Next i
   
   'Araları sil
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = 1 To sonsatir
      sonsutun = Cells(i, Columns.Count).End(xlToLeft).Column
      For j = 1 To sonsutun
        If Cells(i, j).Value = "_" Then
         GoTo sontire
        Else
         sayi = 0 + Cells(i, j).Value
        End If
         If eskisayi + 1 = sayi And Cells(i, j + 1).Value <> "_" Then
            Cells(i, j).Value = "/"
         End If
        eskisayi = sayi
sontire:
      Next j
    Next i
 
 ' denleri ekle
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = 1 To sonsatir
      sonsutun = Cells(i, Columns.Count).End(xlToLeft).Column
      veri = ""
      For j = 1 To sonsutun
          bilgi = Cells(i, j).Value
          If bilgi <> "/" Then
             tire = False
          End If
          
          If tire = False Then

             If bilgi = "/" Then
               tire = True
               veri = veri & "den"
             Else
               tire = False
               veri = veri & bilgi
             End If
          End If
      Next j
      veri = Mid(veri, 1, Len(veri) - 1)
      Cells(i, "A").Value = veri
    Next i
    
    Sheets("Gecicixxxxx").Select
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sayfa1").Select
    Range("A1").Select
    ActiveSheet.Paste
    Columns("A:A").EntireColumn.AutoFit
    Range("A2").Select
   
    If WorksheetExists("Gecicixxxxx") Then Sheets("Gecicixxxxx").Delete
    Sheets("Sayfa1").Select
     Application.DisplayAlerts = True
End Sub


Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

cengiz123 · 12 Aralık 2017

asri hocam merhaba
kod harika olmuş. yalnız bir noktada hata gördüm.

500 501
500 501 511 515 516 517

sonuçlarında hata veriyor.
olması gereken sonuç;
500_501
500_501_511_515to517

yardımcı olursanız sevinirim.

Ardışık sayıları gruplama

cengiz123

Asri

askm

Destek Ekibi

Asri

cengiz123

Asri

cengiz123

Asri

cengiz123

cengiz123

Asri

Asri

cengiz123

cengiz123

systran

Destek Ekibi

cengiz123

systran

Destek Ekibi

cengiz123

Asri

cengiz123