Soru Birden fazla hesap bulunması halinde, hesap nolarını aynı hücrede birleştirme - gösterme?

[Korhan Ayhan]

Merhaba,

Paylaştığınız ofis sürümü bilgilerini mesaj olarak değilde kişisel verilerinizin bulunduğu profilinize girmenizi rica edeceğim. Böylelikle kalıcı olarak görünecektir. Bizlerin profilindeki gibi doldurabilirsiniz.

Profilinizi güncellediğinizde aşağıdaki görselde mavi renkli kısımda bu bilgiler kalıcı olarak görünecektir.

 

[Korhan Ayhan]

Bu kodu deneyiniz.

Option Explicit

Sub Concatenate_Account_No()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim My_Array As Object, My_Data As Variant
    Dim My_Temp_List As Variant, X As Long
    Dim Count_Data As Long, Process_Time As Double
    
    Process_Time = Timer
    
    Set S1 = Sheets("Liste")
    Set S2 = Sheets("Hesapno")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
    My_Data = S2.Range("A2:R" & S2.Cells(S2.Rows.Count, 2).End(3).Row).Value
    
    ReDim My_Temp_List(1 To UBound(My_Data, 1), 1 To 2)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 2) <> "" Then
            If Not My_Array.Exists(My_Data(X, 2)) Then
                Count_Data = Count_Data + 1
                My_Array.Add My_Data(X, 2), Count_Data
                If Not IsError(My_Data(X, 17)) Then
                    If My_Data(X, 17) <> "" Then My_Temp_List(Count_Data, 1) = My_Data(X, 17)
                End If
                If Not IsError(My_Data(X, 18)) Then
                    If My_Data(X, 18) <> "" Then My_Temp_List(Count_Data, 2) = My_Data(X, 18)
                End If
            Else
                If Not IsError(My_Data(X, 17)) Then
                    If My_Data(X, 17) <> "" Then
                        If My_Temp_List(My_Array.Item(My_Data(X, 2)), 1) = "" Then
                            My_Temp_List(My_Array.Item(My_Data(X, 2)), 1) = My_Data(X, 17)
                        Else
                            If Not My_Temp_List(My_Array.Item(My_Data(X, 2)), 1) Like "*" & My_Data(X, 17) & "*" Then
                                My_Temp_List(My_Array.Item(My_Data(X, 2)), 1) = My_Temp_List(My_Array.Item(My_Data(X, 2)), 1) & "-" & My_Data(X, 17)
                            End If
                        End If
                    End If
                End If
                If Not IsError(My_Data(X, 18)) Then
                    If My_Data(X, 18) <> "" Then
                        If My_Temp_List(My_Array.Item(My_Data(X, 2)), 2) = "" Then
                            My_Temp_List(My_Array.Item(My_Data(X, 2)), 2) = My_Data(X, 18)
                        Else
                            If Not My_Temp_List(My_Array.Item(My_Data(X, 2)), 2) Like "*" & My_Data(X, 18) & "*" Then
                                My_Temp_List(My_Array.Item(My_Data(X, 2)), 2) = My_Temp_List(My_Array.Item(My_Data(X, 2)), 2) & "-" & My_Data(X, 18)
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next

    My_Data = S1.Range("B2:B" & S1.Cells(S1.Rows.Count, 2).End(3).Row).Value
    
    S1.Range("Q2:R" & S1.Rows.Count).ClearContents
    S1.Range("Q2:R" & S1.Rows.Count).WrapText = True
    S1.Range("Q:R").HorizontalAlignment = xlCenter
    S1.Range("Q:R").ColumnWidth = 20
    
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 2)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 1) <> "" Then
            If My_Array.Exists(My_Data(X, 1)) Then
                My_List(X, 1) = My_Temp_List(My_Array.Item(My_Data(X, 1)), 1)
                My_List(X, 2) = My_Temp_List(My_Array.Item(My_Data(X, 1)), 2)
            End If
        End If
    Next
    
    S1.Range("Q2").Resize(UBound(My_Data, 1), 2).Value = My_List
    
    Erase My_Temp_List
    Erase My_List
    Erase My_Data
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set My_Array = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[mars2]

Sayın Korhan Ayhan;

Teşekkürler, Kodunuz örnekte sorumsuz çalışmakta olup asıl uygulama işyerinde olduğunda onda deneme imlkanım olmadı ancak unda da sorunsuz çalışacağından eminim