Sınav Dağıtım Programı VBR bilen arkadaşlar

[hsntetik]

Ortalama Yükseltme ve Sorumluluk Sınavları için elinde programı olan arkadaşlar varsa ilginiz ve ekte Bulunan Sınav Dağıtım Programı VBR bilen arkadaşlar bir bakarlarsa memnun olurum.

maktoları aşagıda


Sub aktar()
'If Target.Address <> "$A$2" Then Exit Sub
On Error Resume Next


Set s1 = Sheets("PROGRAM")
Range("B17:H60").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("E21").Select


[a17:h65536].ClearContents
For a = 1 To s1.[f65536].End(xlUp).Row

For d = 8 To 14


If s1.Cells(a, d) = [c7].Value Then
c = c + 1
For b = 1 To 7

Cells(c + 16, b) = s1.Cells(a, b).Value
If d <= 10 Then

Cells(c + 16, b + 1) = "KOMİSYON"
'If d > 10 Then
Else

Cells(c + 16, b + 1) = "GÖZCÜ"
End If
'End If
Next
End If
Next
Next


Range("B17").Select
If IsEmpty(ActiveCell) Then Exit Sub

satir = ActiveCell.Row
sutun = ActiveCell.Column
konum = ActiveCell.Address

sut = 0
Do Until sut = 100

If Not IsEmpty(ActiveCell) Then sonsut = sut
ActiveCell.Offset(0, 1).Select
sut = sut + 1
Loop

Range(konum).Select

sat = 0
Do Until sat = 100

If Not IsEmpty(ActiveCell) Then sonsat = sat
ActiveCell.Offset(1, 0).Select
sat = sat + 1
Loop

Range(Cells(satir, sutun), Cells(sonsat + satir, sonsut + sutun)).Select


Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Range(konum).Select

Range("B16:H60").Select
Selection.Sort Key1:=Range("B17"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveWindow.SmallScroll Down:=-3

Range(konum).Select

End Sub

 

[Metin Karaağaç]

ekteki programın neyini soruyorsunuz?