Yerleşik Birleştir fonksiyonun Hücreye değilde Aralığa müracat eden versiyonu var mı?

[hsayar]

Yerleşik Birleştir fonksiyonun Hücreye değilde Aralığa müracat eden versiyonu var mı?

Arkadaşlar bilindiği üzere birleştir fonksiyonunda birlewşecek hücreleri tek tek fonksiyona tanıtırız:
=BİRLEŞTİR(B2;B3;B4;B5)

gibi ama bunlar toplanacak olsaydı
=topla(B2:B5)

yazmamız yeterli ocaktı. şimdi sorum Aynı Topla Gibi ama metinleri birleştirien fonksiyon mevcutmudur?
metintopla(B2:B5) gibi.

 

[uzmanamele]

merhaba

syn yurttas'ın kft'si işinizi görür mü?

'kodları yazan: Yurttaş
Public Function BİRLEŞTİRA(ALAN As Range, Optional sALAN As String = " ") As String
Dim sonuc As String, c As Range
Application.Volatile ''''' ek satır
On Error GoTo Hata

For Each c In ALAN
    If c <> Empty Then sonuc = sonuc & c.Value & sALAN
Next c
sonuc = Left(sonuc, Len(sonuc) - Len(sALAN))
BİRLEŞTİRA = sonuc

On Error GoTo 0
   Exit Function

Hata:
    BİRLEŞTİRA = "#Error#"

End Function

 

[hsayar]

sn uzmanamele benzeri bendede var ancak buna dizi gönderirsek çuvallıyor

Function MetinTopla(Aralik As Range, Optional Ayraç As String) As String
Application.Volatile

For Each hcr In Aralik.Cells
  StrMetin = StrMetin & hcr.Text
Next
MetinTopla = StrMetin
Set hcr = Nothing
End Function

 

[janveljan]

Sizin yapmak istediğiniz nedir tam olarak anlamadım, bir dizideki bütün değerleri mi ard arda eklesin, yoksa hem dizi hemde erimde mi çalışsın?

 

[hsayar]

Sizin yapmak istediğiniz nedir tam olarak anlamadım, bir dizideki bütün değerleri mi ard arda eklesin, yoksa hem dizi hemde erimde mi çalışsın?

hem çok boyutlu dizinin istediğim boyutu, hem tek boyutlu sizi, hemde erimde çalışsın.
VarType ile dizi ve Aralığın Tipini sorduğumda 8204 diyor.

Aşağıdaki fonksiyonda ayrı ayrı çalışır halleri gösterildi,

Sub testErim()
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("sayfa1")
Dim rng As Range
With Csf
  Set rng = .Range(.Cells(2, 8), .Cells(16, 8))
End With
'MsgBox WorksheetFunction.Sum(rng)
MsgBox MetinTopla(rng)
End Sub


Sub testÇokByut()

With ThisWorkbook.Worksheets("sayfa1")
  arrSut1 = .Range(.Cells(2, 8), .Cells(16, 8)).Value
End With
MsgBox MetinTopla(arrSut1)
End Sub
Sub testTekByut()
arrTest = Array("aaa", "bbbb", "cccc", "dddd")
MsgBox MetinTopla(arrTest)
End Sub

Function MetinTopla(Aralik, Optional Ayraç As String) As String
'MsgBox VarType(Aralik)
Application.Volatile

For Each hcr In Aralik                     'Test Erim
  StrMetin = StrMetin & hcr.Text
Next
'=======================
'For i = LBound(Aralik) To UBound(Aralik)
'  StrMetin = StrMetin & Aralik(i, 1)     'testÇokByut
'  'StrMetin = StrMetin & Aralik(i)     'testTekByut
'Next i

MetinTopla = StrMetin
'Set hcr = Nothing
End Function

Eğer
Aralikin Tipi Hücre ise For each döngüsü,
Aralikin Tipi Dizi ise For next döngüsü,,
çok boyutlu ise birinci satırı
tek boyutlu ise ikinci satırı
şeklinde ayralamak lazım.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz. Kullanıcı tanımlı fonksiyon kullanılmıştır.

Kullanım şekli;

=ÇBİRLEŞTİR(Aralık;Ayraç)

Ayraç kısmı opsiyoneldir dilerseniz boş bırakabilirsiniz.

Kullanılan kodlar;

Option Explicit
 
Private Function ÇBİRLEŞTİR(ARALIK As Range, Optional AYRAÇ As String) As String
    Dim HÜCRE As Range
    Dim SONUÇ As String
    Application.Volatile
    For Each HÜCRE In ARALIK
        If HÜCRE.Value <> Empty Then
            If SONUÇ = Empty Then
            SONUÇ = HÜCRE.Text & AYRAÇ
            Else
            SONUÇ = SONUÇ & HÜCRE.Text & AYRAÇ
            End If
        End If
    Next
    If AYRAÇ <> Empty Then
    ÇBİRLEŞTİR = IIf(InStr(1, SONUÇ, AYRAÇ) > 0, Mid(SONUÇ, 1, Len(SONUÇ) - 1), SONUÇ)
    Else
    ÇBİRLEŞTİR = SONUÇ
    End If
End Function

 

[hsayar]

korhan hocam teşekkür ederim benim isteğim hem dizler, hemde erimde çalışmak. Ben aşağıdaki kodlar ile bir yere kadar geldim;
şimdi bana lazım olan kırmızı satırda işaretlediğim gibi dizinin kaç boyutlu olduğunu öğrenmek...
yardımlarınız için teşekkür ederim.

Function MetinTopla(Aralik, Optional Ayraç As String) As String
Dim DeğişkenTipi$, StrMetin$, i&
Application.Volatile
DeğişkenTipi = TypeName(Aralik)
Select Case DeğişkenTipi
  Case "Range"
    Dim hcr As Range
    For Each hcr In Aralik                     'Test Erim
      StrMetin = StrMetin & hcr.Text & Ayraç
    Next
    Set hcr = Nothing
  Case "Variant()"
    For i = LBound(Aralik) To UBound(Aralik)
[B][COLOR=Red]      'StrMetin = StrMetin & Aralik(i, 1) & Ayraç   'testÇokByut
      StrMetin = StrMetin & Aralik(i)     'testTekByut[/COLOR][/B]
    Next i
  Case Else
End Select
'=======================
MetinTopla = StrMetin
End Function

typname fonksiyonu hakkında detaylı bilgi için:
http://office.microsoft.com/tr-tr/access/HA012289281055.aspx?pid=CH100728911055

 

[hsayar]

Sanki oldu gibi Sizlerde test edrmisiniz?

Function MetinTopla(Aralik, Optional Ayraç As String) As String
Dim DeğişkenTipi$, StrMetin$, i&
Application.Volatile
DeğişkenTipi = TypeName(Aralik)
Select Case DeğişkenTipi
  Case "Range"
    Dim hcr As Range
    For Each hcr In Aralik                     'Test Erim
      StrMetin = StrMetin & hcr.Text & Ayraç
    Next
    Set hcr = Nothing
  Case "Variant()"
'  MsgBox UBound(Aralik, 2)
    For i = LBound(Aralik) To UBound(Aralik)
      dbs = diziboyutsayisi(Aralik)
      If dbs = 0 Then
        StrMetin = StrMetin & Aralik(i)          'testTekByut
      Else
        StrMetin = StrMetin & Aralik(i, dbs)     'testÇokByut
      End If
    Next i
  Case Else
End Select
MetinTopla = StrMetin
End Function

Function diziboyutsayisi(dizi)
'Levent Menteşoğlu
On Error GoTo 10
If IsArray(dizi) = True Then
  For a = 1 To 100
    If UBound(dizi, a) > 0 Then c = c + 1
  Next
End If
10 diziboyutsayisi = c - 1
End Function

örnek yordamar

Sub testErim()
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("sayfa1")
Dim rng As Range
With Csf
  Set rng = .Range(.Cells(2, 8), .Cells(16, 8))
End With
'MsgBox WorksheetFunction.Sum(rng)
MsgBox MetinTopla(rng)
End Sub


Sub testÇokByut()
Dim arrSut1() As Variant
With ThisWorkbook.Worksheets("sayfa1")
  arrSut1 = .Range(.Cells(2, 8), .Cells(16, 8)).Value
End With
MsgBox MetinTopla(arrSut1)
End Sub
Sub testTekByut()
Dim arrTest() As Variant
arrTest = Array("aaa", "bbbb", "cccc", "dddd")
MsgBox MetinTopla(arrTest)
End Sub