- Katılım
- 8 Mart 2009
- Mesajlar
- 504
- Excel Vers. ve Dili
- 2010
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Evren bey, makrolarla böyle bir dosya yapılabilirmi.
Yapın ama bir garantide vermem.Evren bey ilgilendiğiniz için teşekkürler birazdaha Excel sayfasının içene açıklama yapsam uygun olurmu, veyahut foruma,
Option Explicit
Sub VERİ_KONTROL()
Dim S1 As Worksheet, S2 As Worksheet, X As Long, Y As Integer
Dim İLK As Integer, SON As Integer, SAY As Integer, Son_Satır As Long
Application.ScreenUpdating = False
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
S2.Range("B5:E65536").ClearContents
S1.Range("C6:C65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S2.Range("B4"), Unique:=True
Son_Satır = S1.Range("C65536").End(3).Row
For X = 5 To S2.Range("B65536").End(3).Row
If WorksheetFunction.CountIf(S1.Range("C:C"), S2.Cells(X, 2)) > 0 Then
İLK = Evaluate("=MIN(IF(Sayfa1!C7:C" & Son_Satır & "=Sayfa2!B" & X & ",Sayfa1!G7:G" & Son_Satır & "))")
SON = Evaluate("=MAX(IF(Sayfa1!C7:C" & Son_Satır & "=Sayfa2!B" & X & ",Sayfa1!G7:G" & Son_Satır & "))")
For Y = İLK To SON
SAY = Evaluate("=SUMPRODUCT((Sayfa1!C7:C" & Son_Satır & "=Sayfa2!B" & X & ")*(Sayfa1!G7:G" & Son_Satır & "=" & Y & "))")
If SAY = 0 Then
If S2.Cells(X, "C") = "" Then
S2.Cells(X, "C") = Y
Else
S2.Cells(X, "C") = S2.Cells(X, "C") & " - " & Y
End If
ElseIf SAY > 1 Then
If S2.Cells(X, "D") = "" Then
S2.Cells(X, "D") = Y
Else
S2.Cells(X, "D") = S2.Cells(X, "D") & " - " & Y
End If
S2.Cells(X, "E") = SON
End If
Next
End If
Next
Set S1 = Nothing
Set S2 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub