İsimler aynı TC veya Vergi No farklı ise farklı sıralama

[tk123]

Ekteki tabloda bilgi girişi kısmındaki bilgileri tabloya tablo aktar tuşu ile aktarıyor fakat Kişi isimleri aynı ise farklı TC ve Vergi nosu olsa bıle aynı isım olduğu için değerleri birleştiriyor.

İsimler aynı bile olsa Tc ve Vergi no farklı ise ayrı ayrı aktarmasını nasıl sağlarız. Birde bilgi girişindeki adı soyadı arasındaki boşlukları tabloya aktarırken nasıl bır boşluk kalacacak şekilde ayarlarız.

Bilgi girişi kısmında açıklama mevcuttur.

İlginize şimdiden teşekkürler.

 

[tk123]

Tabloya yardımcı olabilecek bir arkadaş varmı acaba ?

 

[mancubus]

Option Explicit

Sub AktarTopla()
'uyarlama ve kaynak:
'http://www.excel.web.tr/f166/mukerrer-kayytlary-birle-tirererek-toplama-t59232/post323337.html

Dim ws1 As Worksheet, ws2 As Worksheet
Dim a, n, Z, veri()
Dim i As Long, sat As Long
Dim rng As Range, cll As Range

Set ws1 = Sheets("Bilgigirişi")
Set ws2 = Sheets("Tablo")

Set rng = ws1.Cells.SpecialCells(xlCellTypeConstants, 23)
For Each cll In rng
    If Len(cll) > Len(WorksheetFunction.Trim(cll)) Then
        cll.Value = WorksheetFunction.Trim(cll)
    End If
Next cll

a = ws1.Range("B5:G" & ws1.[B65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 7)

With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        Z = a(i, 1) & ":" & a(i, 3) & ":" & a(i, 4)
           If Not IsEmpty(Z) Then
                 If Not .exists(Z) Then
                    n = n + 1
                    .Add Z, n
                    veri(n, 1) = n
                    veri(n, 2) = a(i, 1)
                    veri(n, 3) = a(i, 2)
                    veri(n, 4) = a(i, 3)
                    veri(n, 5) = a(i, 4)
                End If
                    veri(.Item(Z), 6) = veri(.Item(Z), 6) + a(i, 5)
                    veri(.Item(Z), 7) = veri(.Item(Z), 7) + a(i, 6)
            End If
    Next i
End With

sat = ws2.[A65536].End(3).Row + 1
If sat < 5 Then sat = 5
ws2.Range(ws2.Cells(5, "A"), ws2.Cells(sat, "G")).ClearContents
ws2.[A5].Resize(n, 7).Value = veri

ws2.Select
MsgBox "Raporlama Tamamlandı", vbInformation, "Bilgi"
Set ws1 = Nothing
Set ws2 = Nothing

End Sub

 

[tk123]

Teşekkür ederim Sayın mancubus

 

[tk123]

Option Explicit

Sub AktarTopla()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim a, n, Z, veri()
Dim i As Long, sat As Long
Dim rng As Range, cll As Range

Set ws1 = Sheets("Bilgigirişi")
Set ws2 = Sheets("Tablo")

Set rng = ws1.Cells.SpecialCells(xlCellTypeConstants, 23)
For Each cll In rng
If Len(cll) > Len(WorksheetFunction.Trim(cll)) Then
cll.Value = WorksheetFunction.Trim(cll)
End If
Next cll

a = ws1.Range("B5:G" & ws1.[B65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 7)

With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
Z = a(i, 1) & ":" & a(i, 3) & ":" & a(i, 4)
If Not IsEmpty(Z) Then
If Not .exists(Z) Then
n = n + 1
.Add Z, n
veri(n, 1) = n
veri(n, 2) = a(i, 1)
veri(n, 3) = a(i, 2)
veri(n, 4) = a(i, 3)
veri(n, 5) = a(i, 4)
End If
veri(.Item(Z), 6) = veri(.Item(Z), 6) + a(i, 5)
veri(.Item(Z), 7) = veri(.Item(Z), 7) + a(i, 6)
End If
Next i
End With

sat = ws2.[A65536].End(3).Row + 1
If sat < 5 Then sat = 5
ws2.Range(ws2.Cells(5, "A"), ws2.Cells(sat, "G")).ClearContents
ws2.[A5].Resize(n, 7).Value = veri
Range("B5:G" & Cells(Rows.Count, "B").End(xlUp).Row).Sort Range("B5")
Application.ScreenUpdating = True
ws2.Select
MsgBox "Raporlama Tamamlandı", vbInformation, "Bilgi"
Set ws1 = Nothing
Set ws2 = Nothing


End Sub

Gönderdiğiniz koda Alfabetik sıralama koduda ekledim daha güzel oldu. ilginize tekrar teşekkürler.