Numara birleştirme yatay liste

[kabrax789]

Merhabalar,
Dikey olarak bulunan numaraları kısaltmak (birleştirmek) için herhangi bir fonsiyon yada macro var mı?
Şimdiden teşekkürler

Sayfa1
A B
1 deneme 1
2 deneme 2
3 deneme 3
4 deneme 4
5 deneme 8
6 TRY 1
7 TRY 2
8 TRY 3
9 TRY 9
10TRY 13

Sayfa2
A B
1 deneme 1-4;8
2 TRY 1-3;9;13

 

[Ömer]

Merhabalar,
Dikey olarak bulunan numaraları kısaltmak (birleştirmek) için herhangi bir fonsiyon yada macro var mı?
Şimdiden teşekkürler

Merhaba,

Eki inceleyiniz.

Modul;

Sub BulTekYaz()
 
    Dim c As Range, ilkadres As Variant, i As Long, S1 As Worksheet
 
    Application.ScreenUpdating = False
    Set S1 = Sheets("Sayfa1")
 
    Sheets("Sayfa2").Select
    Cells.Clear
 
    S1.Range("B1").Copy Range("B1")
    S1.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Range("A1"), Unique:=True
 
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        With S1.Range("A:A")
            Set c = .Find(Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                ilkadres = c.Address
                Do
                    Cells(i, "B") = Cells(i, "B") & ";" & S1.Cells(c.Row, "B")
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> ilkadres
            End If
        End With
        Cells(i, "B") = WorksheetFunction.Substitute(Cells(i, "B"), ";", "", 1)
    Next i
    Application.ScreenUpdating = True
 
End Sub

.

 

[kabrax789]

Çok teşekkürler
Dikey listeyi yataya çevirmek için çok güzel olmuş

Ama benim asıl istediğim ardaşık sayıların ara sayıları gözükmesin istiyorum

ekteki 3.sayfadaki istediğim çıktı var .
Ama ne yazıkkı manuel yaptım.

 

[Ömer]

ekteki 3.sayfadaki istediğim çıktı var .
Ama ne yazıkkı manuel yaptım.

Kodları aşağıdakilerle değiştiriniz.

Sub BulTekYaz()
 
    Dim i As Long, j As Long, Frk As Integer, esk As String
    Dim Mtn As String, S2 As Worksheet
 
    Set S2 = Sheets("Sayfa2")
 
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
 
    Range("A2:B" & Rows.Count).Sort Key1:=Range("A2"), Key2:=Range("B2")
 
    j = 1
    esk = Range("A2")
    Mtn = Range("B2")
    S2.Cells.Clear
 
    Range("A1:B1").Copy S2.Range("A1")
 
    For i = 3 To Cells(Rows.Count, "A").End(3).Row + 1
        If Not Cells(i, "A") = esk Then
            Frk = Abs(Cells(i - 1, "B") - Cells(i - 2, "B"))
            If Frk = 1 Then
                Mtn = Mtn & "-" & Cells(i - 1, "B")
            End If
 
            j = j + 1
            S2.Cells(j, "A") = esk
            S2.Cells(j, "B") = Mtn
            esk = Cells(i, "A")
            Mtn = Cells(i, "B")
        Else
            Frk = Abs(Cells(i, "B") - Cells(i - 1, "B"))
            If Frk > 1 Then
                If Not CDbl(Right(Mtn, 1)) = Cells(i - 1, "B") Then
                    Mtn = Mtn & "-" & Cells(i - 1, "B") & ";" & Cells(i, "B")
                Else
                    Mtn = Mtn & ";" & Cells(i, "B")
                End If
            End If
        End If
    Next i
 
    S2.Select
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam "
 
End Sub

.

 

[kabrax789]

Kodları aşağıdakilerle değiştiriniz.

Sub BulTekYaz()
 
    Dim i As Long, j As Long, Frk As Integer, esk As String
    Dim Mtn As String, S2 As Worksheet
 
    Set S2 = Sheets("Sayfa2")
 
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
 
    Range("A2:B" & Rows.Count).Sort Key1:=Range("A2"), Key2:=Range("B2")
 
    j = 1
    esk = Range("A2")
    Mtn = Range("B2")
    S2.Cells.Clear
 
    Range("A1:B1").Copy S2.Range("A1")
 
    For i = 3 To Cells(Rows.Count, "A").End(3).Row + 1
        If Not Cells(i, "A") = esk Then
            Frk = Abs(Cells(i - 1, "B") - Cells(i - 2, "B"))
            If Frk = 1 Then
                Mtn = Mtn & "-" & Cells(i - 1, "B")
            End If
 
            j = j + 1
            S2.Cells(j, "A") = esk
            S2.Cells(j, "B") = Mtn
            esk = Cells(i, "A")
            Mtn = Cells(i, "B")
        Else
            Frk = Abs(Cells(i, "B") - Cells(i - 1, "B"))
            If Frk > 1 Then
                If Not CDbl(Right(Mtn, 1)) = Cells(i - 1, "B") Then
                    Mtn = Mtn & "-" & Cells(i - 1, "B") & ";" & Cells(i, "B")
                Else
                    Mtn = Mtn & ";" & Cells(i, "B")
                End If
            End If
        End If
    Next i
 
    S2.Select
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam "
 
End Sub

.

Tam istediğim kod


Mükemmelsin.
Tanışmak yemek ismarlamak isterim

Tekrardan teşekkürler

 

[Ömer]

Rica ederim, işinize yaradığına sevindim. Ayrıca davetiniz için ben teşekkür ederim.

.