- Katılım
- 1 Temmuz 2008
- Mesajlar
- 1,748
- Excel Vers. ve Dili
- 2019 TR
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Merhaba
dosyayı tekrar inceleyiniz.
Sub birleştir()
Application.ScreenUpdating = False
Dim a, i As Double
Range("c2:c" & [c65536].End(3).Row).ClearContents
a = Range("a1:a" & [A65536].End(3).Row).Value
For i = 2 To UBound(a, 1)
Cells(i, 3) = Cells(i, 1) & Left(Cells(i, 2), 10)
Cells(i, 3).NumberFormat = "0"
Next
Application.ScreenUpdating = True
End Sub
Sub listele()
Sheets("Sonuç").Range("A2:C" & [A65536].End(3).Row).ClearContents
s = 1
For i = 2 To Sheets("ŞAMPUAN").[A65536].End(3).Row
If Sheets("ŞAMPUAN").[h1].Value = Sheets("ŞAMPUAN").Cells(i, 1) Then
s = s + 1
Sheets("Sonuç").Cells(s, 1) = Sheets("ŞAMPUAN").Cells(i, 1)
Sheets("Sonuç").Cells(s, 2) = Sheets("ŞAMPUAN").Cells(i, 2)
Sheets("Sonuç").Cells(s, 3) = Sheets("ŞAMPUAN").Cells(i, 3)
End If
Next
Range("A2:C" & [A65536].End(3).Row).Sort Key1:=[A2], Order1:=xlAscending
End Sub
Sn.Serkan Yiğit dosyayı yeniledim
Tekrar kontrol edinniz.
Option Explicit
Sub BİRLEŞTİR()
[C2:C65536].ClearContents
With Range("C2:C" & [A65536].End(3).Row)
.NumberFormat = 0
.Formula = "=A2&LEFT(B2,10)"
.NumberFormat = "@"
.Value = .Value
End With
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [G1]) Is Nothing Then Exit Sub
If Not IsEmpty(Target) Then
Target.Select
[A1].AutoFilter Field:=1, Criteria1:=Target
Sheets("Sonuç").Range("A:A").Clear
Range("B1:B" & [B65536].End(3).Row).Copy Sheets("Sonuç").Range("A1")
Sheets("Sonuç").Cells.EntireColumn.AutoFit
[A1].AutoFilter
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End If
End Sub
Option Explicit
Sub GERİ()
[A:A].Clear
Sheets("ŞAMPUAN").Select
End Sub