Mükerrer kayıt sıralama

[mesutaygun70]

http://s3.dosya.tc/server21/vP5Rwi/YeniMicrosoftExcel_al__maSayfas_.xlsx.html
Yukarıda dosyada yaptım verileri forma birleştir formülü ile getirdim ama veri sayfam çok fazla olduğu için her seferinde bunu yapamıyorum. Otamatik olarak mükerrer kayıtlarda araya virgül koyup ikinci mükerrer kaydın verisini yazabilirmiyim.

 

[muygun]

Merhaba;
form sayfasının kod kısmına;

Sub benzersizler_birleştirilmiş()
Application.ScreenUpdating = False
On Error Resume Next
Sheets("form").Range("a1:b65536").ClearContents
Sheets("form").Range("a1:b65536").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("c1").Select
sat = 1
For z = 1 To Sheets("veriler").Cells(65536, "a").End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("veriler").Range("a1:a" & z), Sheets("veriler").Cells(z, "a")) = 1 Then
Sheets("form").Cells(sat, "a") = Sheets("veriler").Cells(z, "a")
Sheets("form").Cells(sat, "a").Borders.LineStyle = xlContinuous
sat = sat + 1
End If
Next
Set s1 = ThisWorkbook.Worksheets("form")
Set s2 = ThisWorkbook.Worksheets("veriler")
For i = 1 To s1.Range("A65536").End(xlUp).Row
For k = 1 To s2.Range("A65536").End(xlUp).Row
If s1.Cells(i, 1) = s2.Cells(k, 1) Then
If s1.Cells(i, 2) = "" Then s1.Cells(i, 2) = s2.Cells(k, 2)
If s1.Cells(i, 2) <> "" Then s1.Cells(i, 2) = s1.Cells(i, 2) & "," & s2.Cells(k, 2)
s1.Cells(i, 2).Borders.LineStyle = xlContinuous
End If
Next k
Next i
Application.ScreenUpdating = True
MsgBox "İşlem BİTTİ.", vbInformation
End Sub

Kodlarını yerleştirin ve bir butona bağlayın.
Veya eki deneyin.
İyi çalışmalar.

 

[mesutaygun70]

Teşekkürler elinize sağlık. Ama ilk kayıttaki veriyi iki defa alıyor neresini düzelteceğimi bilemedim. Yardım edebilirmisiniz.

 

[mesutaygun70]

Birde Private Sub CommandButton1_Click() kod ile nasıl bağlayabilirim. Butonun altına yazınca sarı renkte çıkıyor.

 

[muygun]

Merhaba;
Kodlarda gereken düzenlemeyi yaptım tekrar deneyin.
Ayrıca CommandButton bağlantısını call makro adı şeklinde yapabilirsiniz.
İyi çalışmalar.

Sub benzersizler_birleştirilmiş()
Application.ScreenUpdating = False
On Error Resume Next
Sheets("form").Range("a1:b65536").ClearContents
Sheets("form").Range("a1:b65536").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("c1").Select
sat = 1
For z = 1 To Sheets("veriler").Cells(65536, "a").End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("veriler").Range("a1:a" & z), Sheets("veriler").Cells(z, "a")) = 1 Then
Sheets("form").Cells(sat, "a") = Sheets("veriler").Cells(z, "a")
Sheets("form").Cells(sat, "a").Borders.LineStyle = xlContinuous
sat = sat + 1
End If
Next
Set s1 = ThisWorkbook.Worksheets("form")
Set s2 = ThisWorkbook.Worksheets("veriler")
For i = 1 To s1.Range("A65536").End(xlUp).Row
For k = 1 To s2.Range("A65536").End(xlUp).Row
If s1.Cells(i, 1) = s2.Cells(k, 1) Then
If s1.Cells(i, 2) = "" Then s1.Cells(i, 2) = s2.Cells(k, 2) Else s1.Cells(i, 2) = s1.Cells(i, 2) & "," & s2.Cells(k, 2)
s1.Cells(i, 2).Borders.LineStyle = xlContinuous
End If
Next k
Next i
Application.ScreenUpdating = True
MsgBox "İşlem BİTTİ.", vbInformation
End Sub

Private Sub CommandButton1_Click()
Call benzersizler_birleştirilmiş
End Sub

İyi çalışmalar.

 

[mesutaygun70]

Kolay gelsin. Yukarıdaki en son kodu biraz değiştirmem gereklide yardımınıza ihtiyacım var.
Eğer "yıllık" ibaresi varsa b sütununa, "yıllık" ibaresi yoksa c sütununa atmasını sağlayabilirmiyiz.