Hücre sınırı

[oydemir]

Aşağıdaki makro kullanmaktayım hocalarıma teşekkür ederim.
Fakat birleştirilen değerler karakter sayısı hücreye sığmayınca kod hata veriyor.
bu hatayı hücrenin aldığı kadar yazdırabilir miyiz.
Böyle nadir durumlar için hücrenin başına "HATALI gösterim " diyebilirmiyiz.
Sub işlem()
Dim son&, veri
Range("H1:H" & Rows.Count).ClearContents
son = Range("B" & Rows.Count).End(xlUp).Row
veri = Range("B1:E" & son).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(veri)
.Item(veri(i, 1)) = .Item(veri(i, 1)) & "," & veri(i, 4)
Next i
For i = 1 To UBound(veri)
veri(i, 1) = Mid(.Item(veri(i, 1)), 2)
Next i
For i = 1 To UBound(veri)
.RemoveAll
For Each elem In Split(veri(i, 1), ",")
If elem <> "" Then .Item(elem) = Null
Next elem
veri(i, 1) = Join(.keys)
Next i
Range("H1:H" & son).Value = veri
End With
MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[muhasebeciyiz]

Option Explicit

Sub işlem()
    Const MAXLEN As Long = 32767
    Const PREFIX As String = "HATALI gösterim "
    
    Dim son As Long, veri, i As Long
    Dim dict As Object, uniq As Object
    Dim k As String, s As String, elem As Variant
    
    Range("H1:H" & Rows.Count).ClearContents
    
    son = Cells(Rows.Count, "B").End(xlUp).Row
    If son < 1 Then Exit Sub
    
    veri = Range("B1:E" & son).Value
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(veri, 1)
        k = Trim$(CStr(veri(i, 1)))
        If Len(k) > 0 Then
            s = Trim$(CStr(veri(i, 4)))
            If Len(s) > 0 Then
                If dict.Exists(k) Then
                    dict(k) = dict(k) & "," & s
                Else
                    dict.Add k, s
                End If
            Else
                If Not dict.Exists(k) Then dict.Add k, vbNullString
            End If
        End If
    Next i
    
    For i = 1 To UBound(veri, 1)
        k = Trim$(CStr(veri(i, 1)))
        
        If Len(k) = 0 Then
            veri(i, 1) = vbNullString
        ElseIf Not dict.Exists(k) Then
            veri(i, 1) = vbNullString
        Else
            s = CStr(dict(k))
            
            Set uniq = CreateObject("Scripting.Dictionary")
            If Len(s) > 0 Then
                For Each elem In Split(s, ",")
                    elem = Trim$(CStr(elem))
                    If Len(elem) > 0 Then
                        If Not uniq.Exists(elem) Then uniq.Add elem, Empty
                    End If
                Next elem
            End If
            
            s = Join(uniq.Keys, ",")
            
            If Len(s) > MAXLEN Then
                If Len(PREFIX) < MAXLEN Then
                    s = PREFIX & Left$(s, MAXLEN - Len(PREFIX))
                Else
                    s = Left$(PREFIX, MAXLEN)
                End If
            End If
            
            veri(i, 1) = s
        End If
    Next i
    
    Range("H1:H" & son).Value = Application.Index(veri, 0, 1)
    
    MsgBox "İşlem TAMAM.", vbInformation
End Sub

Birde bunu denemisiniz

 

[oydemir]

veri(i, 1) = Mid$(.Item(veri(i, 1)), 2) satırında hata verdi

 

[oydemir]

ilginiz için teşekkür ederim

 

[muhasebeciyiz]

2 nolu mesajı güncelledim deneyiniz

 

[oydemir]

bu hata ne demek (neyi ifade ediyor)veri(i, 1) = Mid$(.Item(veri(i, 1)), 2) satırında hata verdi

 

[muhasebeciyiz]

Bu satır şunu varsayıyor:

1. veri(i,1) boş değil
2. Dictionary içinde bu anahtar mutlaka var
3. .Item(veri(i,1)) String döndürüyor
   Bu üç varsayımdan biri bile bozulursa hata olur.

.Item(veri(i,1)) Dictionary’de olmayan anahtar
excel kod özetle diyorki Benden string bekliyorsun ama bana Null / olmayan / geçersiz bir şey verdin.”

Kodda bu bloğu bul ve değiştir

Dim k As String, t As String

For i = 1 To UBound(veri, 1)
    k = Trim$(CStr(veri(i, 1)))

    If Len(k) = 0 Then
        veri(i, 1) = vbNullString
    ElseIf Not .Exists(k) Then
        veri(i, 1) = vbNullString
    Else
        t = CStr(.Item(k))
        If Len(t) >= 2 Then
            veri(i, 1) = Mid$(t, 2)
        Else
            veri(i, 1) = vbNullString
        End If
    End If
Next i

 

[oydemir]

Satır sayıs 141905 2 saat oldu sonuç alamadım.Çalışıp Çalışmadıgını test etme imkanını bulamadım.Başka Bir imkanı olabilirmi.

 

[Korhan Ayhan]

Örnek dosya paylaşarak verilerim şu şekilde ben şu şekilde bir sonuca ulaşmak istiyorum şeklinde tarif ederseniz alternatif çözümler bulunabilir.