Çözüldü Kelimeleri Bölmeden Parça Al Fonksiyonu

[MsYiLDiRiM]

Merhaba Arkadaşlar,

Elimde bir adres listesi var, bunları 40 karakter sınırına göre parçalamam lazım, ama adreslerin absürt parçalara ayrılmasını istemiyoruz. bunu nasıl yapabiliriz

Örneğin

Atatürk Bulvarı Yenice Sokak 8979/1 İlkadım / Ankara

gibi bir adresi

Atatürk Bulvarı Yenice Sokak 8979/1 İlka

dım / Ankara

olarak bölebiliyorum. İlkadım kelimesi 40 karaktere sığmadığı için metnin

Atatürk Bulvarı Yenice Sokak 8979/1

İlkadım / Ankara

olarak bölünmesi mümkün mü nasıl bir formül yazmalıyız.

Not: Adres farazidir.

 

[excelokyanus500]

Deneyin..

Public Sub split_42()

''https://forum.ozgrid.com/forum/index.php?thread/83450-split-text-into-whole-words-not-exceeding-x-characters/
Dim Last_row As Long
Dim lLoop As Long
Dim Full_String As String
Dim String1 As String
Dim String2 As String
Dim breaking_point As Integer


With ActiveSheet


    Last_row = .Range("A" & Rows.Count).End(xlUp).Row
    
    For lLoop = Last_row To 1 Step -1
        Full_String = Trim(.Cells(lLoop, 1))
        If Len(Full_String) > 40 Then
            breaking_point = InStrRev(Full_String, " ", 40)
            String1 = Left(Full_String, breaking_point)
            String2 = Mid(Full_String, breaking_point + 1)
            .Rows(lLoop + 1).Insert shift:=xlDown
            .Cells(lLoop, 1) = String1
            .Cells(lLoop + 1, 1) = String2
        End If
    Next
End With
End Sub

 

[Erdem Akdemir]

Daha fazla örnek adres gerekli. %100 yapmak bazen imkansız olabiliyor.

 

[hayri13]

Merhaba
aşağıdaki formülleri kontrol edermisiniz?

ilk parça; (B1 hücresine)
"=+KIRP(SOLDAN(SOLDAN(A1;40);UZUNLUK(SOLDAN(A1;40))-TOPLA(EĞER(EĞERHATA(MBUL(" ";SAĞDAN(SOLDAN(A1;40);SÜTUN($A$1:$V$1)));0)=0;1;0))))"

ikinci parça;
"=+KIRP(YERİNEKOY(A1;B1;""))"

 

[MsYiLDiRiM]

Deneyin..

Public Sub split_42()

''https://forum.ozgrid.com/forum/index.php?thread/83450-split-text-into-whole-words-not-exceeding-x-characters/
Dim Last_row As Long
Dim lLoop As Long
Dim Full_String As String
Dim String1 As String
Dim String2 As String
Dim breaking_point As Integer


With ActiveSheet


    Last_row = .Range("A" & Rows.Count).End(xlUp).Row
 
    For lLoop = Last_row To 1 Step -1
        Full_String = Trim(.Cells(lLoop, 1))
        If Len(Full_String) > 40 Then
            breaking_point = InStrRev(Full_String, " ", 40)
            String1 = Left(Full_String, breaking_point)
            String2 = Mid(Full_String, breaking_point + 1)
            .Rows(lLoop + 1).Insert shift:=xlDown
            .Cells(lLoop, 1) = String1
            .Cells(lLoop + 1, 1) = String2
        End If
    Next
End With
End Sub

Çok teşekkür ederim, İngilizce arama yapmaya çalıştım ama bir türlü bu kaynağı bulamamıştım, göndermiş olduğunuz kod sadece iki parçaya bölüyordu ufak bir güncelleme ile birkaç adımlı çalıştırmaya uygun çok parçaya ayrılabilecek şekilde ayarladık. ("targeti" değişkeninin değiştirilmesiyle )

Public Sub split_42()


Dim Last_row As Long
Dim lLoop As Long
Dim Full_String As String
Dim String1 As String
Dim String2 As String
Dim breaking_point As Integer
Dim targeti As Integer

targeti = 8
With ActiveSheet


    Last_row = .Range("a" & Rows.Count).End(xlUp).Row
   
    For lLoop = Last_row To 1 Step -1
        Full_String = Trim(.Cells(lLoop, targeti))
        If Len(Full_String) > 40 Then
            breaking_point = InStrRev(Full_String, " ", 40)
            String1 = Left(Full_String, breaking_point)
            String2 = Mid(Full_String, breaking_point + 1)
            '.Rows(lLoop + 1).Insert shift:=xlDown
            .Cells(lLoop, targeti) = String1
            .Cells(lLoop, targeti + 1) = String2
        Else
        .Cells(lLoop, targeti) = Full_String
        End If
    Next
End With
End Sub

Merhaba
aşağıdaki formülleri kontrol edermisiniz?

ilk parça; (B1 hücresine)
"=+KIRP(SOLDAN(SOLDAN(A1;40);UZUNLUK(SOLDAN(A1;40))-TOPLA(EĞER(EĞERHATA(MBUL(" ";SAĞDAN(SOLDAN(A1;40);SÜTUN($A$1:$V$1)));0)=0;1;0))))"

ikinci parça;
"=+KIRP(YERİNEKOY(A1;B1;""))"

teşekkür ederim, adreslerdeki karakter sayısı 200 ü bulabildiği için macro ile yenilenebilir yapmak daha karlı ama daha küçük operasyonlar için formülünüzü kayıt ettim

 

[hayri13]

Rica ederim,
çok uzun karakterli yazılar için, formüldeki "SÜTUN($A$1:$V$1)" kısmını "SÜTUN($A$1:$ZZ$1)" olarak yada "SATIR($A$1:$A$999)" olarak değiştirebilirsiniz.

 

[excelokyanus500]

Konu çözülmüş. Buda farklı bir yaklaşım olarak kayıtta kalsın.

Sub CumleBolme()
    Dim x, y, z, i As Long, ii As Long
    'ozgrid
    With ActiveSheet
        x = .Cells(1).CurrentRegion
        ReDim y(1 To UBound(x), 1 To 7)
        For i = 2 To UBound(x) ' 2. den itibaren
            z = Split(x(i, 1))
            For ii = LBound(z) To UBound(z)
                If Len(y(i, 1)) + Len(z(ii)) < 40 And y(i, 2) = "" Then
                    y(i, 1) = Trim(y(i, 1) & " " & z(ii))
                ElseIf Len(y(i, 2)) + Len(z(ii)) < 40 And y(i, 3) = "" Then
                    y(i, 2) = Trim(y(i, 2) & " " & z(ii))
               ElseIf Len(y(i, 3)) + Len(z(ii)) < 40 And y(i, 4) = "" Then
                    y(i, 3) = Trim(y(i, 3) & " " & z(ii))
               ElseIf Len(y(i, 4)) + Len(z(ii)) < 40 And y(i, 5) = "" Then
                    y(i, 4) = Trim(y(i, 4) & " " & z(ii))
               ElseIf Len(y(i, 5)) + Len(z(ii)) < 40 And y(i, 6) = "" Then
                    y(i, 5) = Trim(y(i, 5) & " " & z(ii))
                ElseIf Len(y(i, 6)) + Len(z(ii)) < 40 And y(i, 7) = "" Then
                    y(i, 6) = Trim(y(i, 6) & " " & z(ii))
                Else
                    y(i, 7) = Trim(y(i, 7) & " " & z(ii))
                End If
            Next
        Next
        .[b1].Resize(UBound(y), 7) = y
        .Columns(2).Resize(, 7).AutoFit
    End With
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=LEN(R[1]C)"
    Selection.AutoFill Destination:=Range("B1:H1"), Type:=xlFillDefault
End Sub