Листинг программы
Microsoft Excel Objects
ЭтаКнига
Private Sub Workbook_Open()
Dim MyBar As CommandBar
Set MyBar = Application.CommandBars.Add
With MyBar
.Visible = True
.Position = msoBarTop
.Name = "Соревнования"
End With
With MyBar.Controls.Add(Type:=msoControlButton)
.Style = msoButtonCaption
.Caption = "Соревнования"
.Enabled = True
.OnAction = "ВызовФормы"
End With
With MyBar.Controls.Add(Type:=msoControlButton)
.Style = msoButtonCaption
.Caption = "О программе"
.Enabled = True
.OnAction = "ЭтаКнига.Информация"
End With
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
For Each Bar In Application.CommandBars
If Bar.Name = "Соревнования" Then
Bar.Delete
Exit For
End If
Next
End Sub
Sub Информация()
MsgBox ("Разработчик программы" & Chr(13) & _
"Студентка группы МИТ-14-2" & Chr(13) & "Института ИТАСУ" & Chr(13) & "Квасова Виктория Олеговна"), vbOKOnly + vbInformation
End Sub
Forms
FrmВыбора
Option Base 1
Sub UserForm_Initialize()
cmdОК.Default = True
cmdОтмена.Cancel = True
Dim Стили() As String
Dim Стиль As String
Dim НомерСтроки As Integer
Dim КолСтилей, k, i, j As Integer
Call СуществованиеФайла
Call СуществованиеЛиста
ReDim Preserve Стили(1) As String
Стили(1) = Trim(Cells(2, 3).Value)
КолСтилей = 1
НомерСтроки = 2
While Trim(Cells(НомерСтроки, 1).Value) <> ""
Стиль = Trim(Cells(НомерСтроки, 3).Value)
For j = 1 To КолСтилей
If Стиль = Стили(j) Then GoTo n3
Next j
КолСтилей = КолСтилей + 1
ReDim Preserve Стили(КолСтилей) As String
Стили(КолСтилей) = Trim(Cells(НомерСтроки, 3).Value)
n3: НомерСтроки = НомерСтроки + 1
Wend
For i = 1 To КолСтилей - 1
Стиль = Стили(i)
k = i
For j = i + 1 To КолСтилей
If Стили(j) >= Стиль Then
Else
Стиль = Стили(j)
Стили(j) = Стили(k)
Стили(k) = Стиль
End If
Next
Next i
frmВыбора.CboСтиль.List = Стили
frmВыбора.CboСтиль.Value = Стили(1)
frmВыбора.optДевушки.Value = True
End Sub
Sub cmdОК_Click()
Dim Стиль, Пол, Имя As String
Dim КолУчастников As Integer
Стиль = CboСтиль.Value
If optДевушки.Value = True Then
Пол = "Ж"
Имя = "Девушки"
Else
Пол = "М"
Имя = "Юноши"
End If
Unload Me
Call СохранениеНовогоФайла(Стиль, Имя, Пол)
Call ВыводДанных(Стиль, Пол, Имя)
MsgBox "Операция завершена!", vbInformation
End Sub
Sub cmdОтмена_Click()
Unload Me
End Sub
Modules
Module1
Sub ВызовФормы()
frmВыбора.Show
End Sub
Вывод
Public Имя, Стиль, Пол As String
Public flag, КолУчастников As Integer
Sub ВыводДанных(Стиль, Пол, Имя)
Dim НомерСтроки, flag, i, j As Integer
Dim КолСтилей As Integer
Dim Участники(), temp() As String
НовоеИмя = LCase(Имя)
КолУчастников = 0
НомерСтроки = 2
Workbooks("Участники соревнований.xls").Activate
While Cells(НомерСтроки, 1).Value <> ""
If Cells(НомерСтроки, 3).Value = Стиль And Cells(НомерСтроки, 6).Value = Пол Then
КолУчастников = КолУчастников + 1
ReDim Preserve Участники(7, КолУчастников)
Участники(1, КолУчастников) = КолУчастников
Участники(2, КолУчастников) = _
Cells(НомерСтроки, 2).Value
Участники(3, КолУчастников) = _
Cells(НомерСтроки, 1).Value
Участники(4, КолУчастников) = _
Cells(НомерСтроки, 4).Value
Участники(5, КолУчастников) = _
Cells(НомерСтроки, 5).Value
Участники(6, КолУчастников) = _
Cells(НомерСтроки, 7).Value
Участники(7, КолУчастников) = _
Cells(НомерСтроки, 8).Value
End If
НомерСтроки = НомерСтроки + 1
Wend
ReDim temp(7, КолУчастников)
For j = 1 To КолУчастников
For i = 1 To КолУчастников
If Val(Участники(4, j)) < Val(Участники(4, i)) Then
temp(1, i) = j
temp(2, i) = Участники(2, i)
temp(3, i) = Участники(3, i)
temp(4, i) = Участники(4, i)
temp(5, i) = Участники(5, i)
temp(6, i) = Участники(6, i)
temp(7, i) = Участники(7, i)
Участники(1, i) = i
Участники(2, i) = Участники(2, j)
Участники(3, i) = Участники(3, j)
Участники(4, i) = Участники(4, j)
Участники(5, i) = Участники(5, j)
Участники(6, i) = Участники(6, j)
Участники(7, i) = Участники(7, j)
Участники(1, j) = temp(1, i)
Участники(2, j) = temp(2, i)
Участники(3, j) = temp(3, i)
Участники(4, j) = temp(4, i)
Участники(5, j) = temp(5, i)
Участники(6, j) = temp(6, i)
Участники(7, j) = temp(7, i)
ElseIf Val(Участники(4, j)) = _
Val(Участники(4, i)) Then
If CDbl(Участники(7, j)) < _
CDbl(Участники(7, i)) Then
temp(1, i) = j
temp(2, i) = Участники(2, i)
temp(3, i) = Участники(3, i)
temp(4, i) = Участники(4, i)
temp(5, i) = Участники(5, i)
temp(6, i) = Участники(6, i)
temp(7, i) = Участники(7, i)
Участники(1, i) = i
Участники(2, i) = Участники(2, j)
Участники(3, i) = Участники(3, j)
Участники(4, i) = Участники(4, j)
Участники(5, i) = Участники(5, j)
Участники(6, i) = Участники(6, j)
Участники(7, i) = Участники(7, j)
Участники(1, j) = temp(1, i)
Участники(2, j) = temp(2, i)
Участники(3, j) = temp(3, i)
Участники(4, j) = temp(4, i)
Участники(5, j) = temp(5, i)
Участники(6, j) = temp(6, i)
Участники(7, j) = temp(7, i)
End If
End If
Next i
Next j
Workbooks(Стиль & "-" & НовоеИмя & ".xls").Activate
For i = 1 To КолУчастников
Cells(i + 2, 1).Value = Участники(1, i)
Cells(i + 2, 2).Value = Участники(2, i)
Cells(i + 2, 3).Value = Участники(3, i)
Cells(i + 2, 4).Value = Участники(4, i)
Cells(i + 2, 5).Value = Участники(5, i)
Cells(i + 2, 6).Value = Участники(6, i)
Cells(i + 2, 7).Value = CDbl(Участники(7, i))
Next i
ActiveWorkbook.Author = "Квасова В.О."
Range("A1").FormulaR1C1 = Стиль
Range("B1").FormulaR1C1 = Имя
Range("A2").FormulaR1C1 = "№ п.п."
Range("B2").FormulaR1C1 = "Участник соревнования"
Range("C2").FormulaR1C1 = "Спортивный клуб"
Range("D2").FormulaR1C1 = "Дистанция"
Range("E2").FormulaR1C1 = "Год рождения"
Range("F2").FormulaR1C1 = "Разряд"
Range("G2").FormulaR1C1 = "Результат"
Range("A1,B1").Select
With Selection.Font
.Name = "Arial Cyr"
.Size = 12
.Italic = True
.Bold = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Range("A2:G2").Select
With Selection.Font
.Name = "Calibri"
.Size = 11
Italic = False
.Bold = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Range(Cells(3, 1), Cells(КолУчастников + 2, 7)).Select
With Selection.Font
.Name = "Calibri"
.Size = 12
.Bold = True
End With
Range(Cells(2, 1), Cells(КолУчастников + 2, 7)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlDouble
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
If КолУчастников <> 0 Then
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If
Columns("A:A").ColumnWidth = 17
Columns("B:B").ColumnWidth = 25
Columns("C:C").ColumnWidth = 18
Columns("D:D").ColumnWidth = 11
Columns("E:E").ColumnWidth = 15
Columns("F:F").ColumnWidth = 9
Columns("G:G").ColumnWidth = 11
Range("A1").Select
ActiveWorkbook.Save
End Sub