mail adresi birleştirme

[spacebar]

Değerli üstadlarım, aşağıda belirttğim kodlar A sutununda mail adreslerini birleştiriyor. ancak bu kodları 25 li gruplar haline yapmak mümkünmüdür. yani 1-25, 26-50, 51-75, 76-100 ......... gibi. Bu birleştirdiği adresleri B sutunda 1 , 26, 51, 76 ...... şeklinde devam edecek şekilde düzenlenebilir mi . Yardımlarınız için teşekkürler...

Sub mailbirlestir()
Worksheets("makro sayfası").Cells(1, 2) = Cells(1, 1)
For x = 2 To [a10000].End(3).Row
Worksheets("makro sayfası").Cells(1, 2) = Worksheets("makro sayfası").Cells(1, 2) & ";" & Cells(x, 1)
Next x
End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Mail_Birlestir()
    Dim X As Long
    
    With Worksheets("makro sayfası")
        .Range("B:B").ClearContents
        .Range("B1") = .Range("A1")
    
        For X = 2 To .Cells(.Rows.Count, 1).End(3).Row Step 25
            .Cells(X, 2) = Join(Application.Transpose(.Cells(X, 1).Resize(25, 1)), ";")
        Next
    End With

    MsgBox "Mail adresleri birleştirilmiştir."
End Sub

 

[spacebar]

Üstad teşekkür ederim. mükemmel çalışıyor. ellerinize sağlık.

 

[ÖmerFaruk]

İzninizle Korhan bey

Korhan Ayhan beyin kodunda ufak bir revize yaptım.
Hem B1 den itibaren yazsın hem de 25 in katlarından eksik bir liste varsa boş satırlra ";" koymasın diye.
Gerçi siz "mükemmel çalışıyor" dediniz ama sorunuzda farklıydı isteğiniz.
"Bu birleştirdiği adresleri B sutunda 1 , 26, 51, 76 ...... şeklinde devam edecek şekilde düzenlenebilir mi "

Sub Mail_Birlestir()
Dim X As Long
    With Worksheets("Sayfa2")
        .Range("B:B").ClearContents
        For X = 1 To .Cells(.Rows.Count, 1).End(3).Row Step 25
            .Cells(X, 2) = Join(Application.Transpose(.Cells(X, 1).Resize(25, 1)), ";")
            If X + 24 > .Cells(.Rows.Count, 1).End(3).Row Then
                .Cells(X, 2) = Left(.Cells(X, 2), Len(.Cells(X, 2)) - X - 24 + .Cells(.Rows.Count, 1).End(3).Row)
                Exit Sub
            End If
        Next X
    End With
    MsgBox "Mail adresleri birleştirilmiştir."
End Sub

 

[spacebar]

Sayın NextLevel teşekkür ederim ilginize. buradaki düzenleme yerinde olmuş. ellerinize sağlık.

 

[Korhan Ayhan]

"Filter" özelliği kullanılarak aşağıdaki gibi de sonuca gidilebilir.

Alternatif olsun;

Option Explicit

Sub Mail_Birlestir()
    Dim X As Long, Veri As Variant
   
    With Worksheets("makro sayfası")
        .Range("B:B").ClearContents
        .Range("B1") = .Range("A1")
   
        For X = 2 To .Cells(.Rows.Count, 1).End(3).Row Step 25
            Veri = Application.Transpose(Application.Evaluate("=IF(LEN(" & _
            .Cells(X, 1).Resize(25).Address & ")>0," & .Cells(X, 1).Resize(25).Address & ",""#"")"))
            .Cells(X, 2) = Join(Filter(Veri, "#", False), ";")
        Next
    End With

    MsgBox "Mail adresleri birleştirilmiştir."
End Sub

Bu da IF sorgusu ile alternatif;

Option Explicit

Sub Mail_Birlestir()
    Dim X As Long
    
    With Worksheets("makro sayfası")
        .Range("B:B").ClearContents
        .Range("B1") = .Range("A1")
    
        For X = 2 To .Cells(.Rows.Count, 1).End(3).Row Step 25
            .Cells(X, 2) = Join(Application.Transpose(.Cells(X, 1).Resize(25, 1)), ";")
            If Right(.Cells(X, 2), 2) = ";;" Then .Cells(X, 2) = Mid(.Cells(X, 2), 1, InStr(1, .Cells(X, 2), ";;") - 1)
            If Right(.Cells(X, 2), 1) = ";" Then .Cells(X, 2) = Left(.Cells(X, 2), Len(.Cells(X, 2)) - 1)
        Next
    End With
    
    MsgBox "Mail adresleri birleştirilmiştir."
End Sub

 

[spacebar]

"Filter" özelliği kullanılarak aşağıdaki gibi de sonuca gidilebilir.

Alternatif olsun;

Option Explicit

Sub Mail_Birlestir()
    Dim X As Long, Veri As Variant
  
    With Worksheets("makro sayfası")
        .Range("B:B").ClearContents
        .Range("B1") = .Range("A1")
  
        For X = 2 To .Cells(.Rows.Count, 1).End(3).Row Step 25
            Veri = Application.Transpose(Application.Evaluate("=IF(LEN(" & _
            .Cells(X, 1).Resize(25).Address & ")>0," & .Cells(X, 1).Resize(25).Address & ",""#"")"))
            .Cells(X, 2) = Join(Filter(Veri, "#", False), ";")
        Next
    End With

    MsgBox "Mail adresleri birleştirilmiştir."
End Sub

Bu da IF sorgusu ile alternatif;

Option Explicit

Sub Mail_Birlestir()
    Dim X As Long
   
    With Worksheets("makro sayfası")
        .Range("B:B").ClearContents
        .Range("B1") = .Range("A1")
   
        For X = 2 To .Cells(.Rows.Count, 1).End(3).Row Step 25
            .Cells(X, 2) = Join(Application.Transpose(.Cells(X, 1).Resize(25, 1)), ";")
            If Right(.Cells(X, 2), 2) = ";;" Then .Cells(X, 2) = Mid(.Cells(X, 2), 1, InStr(1, .Cells(X, 2), ";;") - 1)
            If Right(.Cells(X, 2), 1) = ";" Then .Cells(X, 2) = Left(.Cells(X, 2), Len(.Cells(X, 2)) - 1)
        Next
    End With
   
    MsgBox "Mail adresleri birleştirilmiştir."
End Sub

teşekkür ederim hepsi işime yaradı. ellerinize sağlık. iyi geceler dilerim.