Tevfik_Kursun
Altın Üye
- Katılım
- 30 Temmuz 2012
- Mesajlar
- 3,902
- Excel Vers. ve Dili
- Office 2016 Pro - Türkçe 64 Bit
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub x1()
Dim Say As Integer, i As Integer, k As Integer
Dim Dizi, Hoca, Dersler
Dizi = Range("K1:L" & Range("K1").End(xlDown).Row).Value
Hoca = Range("A2:I" & Range("A2").End(xlDown).Row).Value
Set Dersler = CreateObject("Scripting.Dictionary")
For i = LBound(Hoca, 1) To UBound(Hoca, 1)
Say = 0
For k = 3 To 9
If Hoca(i, k) > 0 Then
If Dersler.Exists(Hoca(i, 1)) Then
Dersler(Hoca(i, 1)) = Dersler(Hoca(i, 1)) & "//" & Hoca(i, k)
Else
Dersler.Add Hoca(i, 1), Hoca(i, k)
End If
End If
Next k
If Not Dersler.Exists(Hoca(i, 1)) Then Dersler.Add Hoca(i, 1), "Yok"
Next i
ReDim Liste(1 To UBound(Dizi, 1), 1 To 2)
For i = LBound(Dizi, 1) To UBound(Dizi, 1)
Liste(i, 1) = Dizi(i, 1)
Part1 = Left(Dizi(i, 1), Len(Dizi(i, 1)) - 2)
Part2 = Right(Dizi(i, 1), 2) * 1
Bul = Split(Dersler(Part1), "//")
If Bul(0) = "Yok" Then Liste(i, 2) = "Hata": GoTo Devam1
If UBound(Bul) = 0 Then Liste(i, 2) = Bul(0): Dersler(Part1) = "Yok": GoTo Devam1
Ara = WorksheetFunction.RandBetween(0, UBound(Bul))
Liste(i, 2) = Bul(Ara)
Say = 0
For k = 0 To UBound(Bul)
If k <> Ara Then
If Say = 0 Then
Dersler(Part1) = Bul(k)
Say = Say + 1
Else
Dersler(Part1) = Dersler(Part1) & "//" & Bul(k)
End If
End If
Next k
Devam1:
Next i
Range("K1").Resize(UBound(Liste), 2) = Liste
End Sub