- Katılım
- 30 Mart 2015
- Mesajlar
- 27
- Excel Vers. ve Dili
- excel2007
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
tekrar konu açmayalım siz aktarabilirmisiniz.aktarmasını bilmiyorum
Sub KOD()
Set dt = Sheets("data")
Set s1 = Sheets("Sayfa1")
x = 3
s1.Range("A3:J65500").ClearContents
For a = 4 To dt.Range("B65500").End(3).Row
If dt.Cells(a, "B") <> dt.Cells(a + 1, "B") Or _
dt.Cells(a, "C") <> dt.Cells(a + 1, "C") Or _
dt.Cells(a, "D") <> dt.Cells(a + 1, "D") Or _
dt.Cells(a, "E") <> dt.Cells(a + 1, "E") Or _
dt.Cells(a, "J") <> dt.Cells(a + 1, "J") Then
s1.Cells(x, "A") = dt.Cells(a, "J")
s1.Cells(x, "B") = dt.Cells(a, "B")
s1.Cells(x, "C") = dt.Cells(a, "C")
s1.Cells(x, "D") = dt.Cells(a, "D")
s1.Cells(x, "E") = dt.Cells(a, "E")
x = x + 1
End If
Next
s1.Range("A3:J65500").Sort s1.Range("A3")
End Sub
Sub KOD()
Set dt = Sheets("data")
Set s1 = Sheets("Sayfa1")
x = 3
s1.Range("A3:J65500").ClearContents
For a = 4 To dt.Range("B65500").End(3).Row
If (dt.Cells(a, "B") <> dt.Cells(a + 1, "B") Or _
dt.Cells(a, "C") <> dt.Cells(a + 1, "C") Or _
dt.Cells(a, "D") <> dt.Cells(a + 1, "D") Or _
dt.Cells(a, "E") <> dt.Cells(a + 1, "E") Or _
dt.Cells(a, "J") <> dt.Cells(a + 1, "J")) And _
dt.Cells(a, "J") <> "" Then
s1.Cells(x, "A") = dt.Cells(a, "J")
s1.Cells(x, "B") = dt.Cells(a, "B")
s1.Cells(x, "C") = dt.Cells(a, "C")
s1.Cells(x, "D") = dt.Cells(a, "D")
s1.Cells(x, "E") = dt.Cells(a, "E")
x = x + 1
End If
Next
s1.Range("A3:J65500").Sort s1.Range("A3")
End Sub