Dim CountOfSheets As Integer
Dim CountOfUsers As Integer
Dim Fn1 As String
Dim i As Integer 'Переменная - счётчик
Dim j As Integer
Dim n1 As Integer
Dim k As Integer
Fn1 = "Тест.xls"
Dim q1 As Integer
Dim q2 As Integer
Dim q3 As Integer
ОСНОВНАЯ ЧАСТЬ
GreetMe4
FNXLS = FileNameXLS
If FNXLS = " " Then Exit Sub
StartTime = Timer
FNO = FileNameOnly(FNXLS)
MsgBox "Работаем с файлом: " & FNO
Workbooks.Open FNO 'Открытие рабочей книги с названием, соответствующим значению переменной FNO на чтение
CountOfSheets = Sheets.Count 'Определение количества листов в книге
CountOfUsers = Num(FNO)
Workbooks(Fn1).Worksheets(1).Range("A1:IV256").Clear
Workbooks(FNO).Sheets(1).Cells(2, 2).Copy Workbooks(Fn1).Sheets(1).Cells(2, 2)
Workbooks(FNO).Sheets(1).Cells(3, 2).Copy Workbooks(Fn1).Sheets(1).Cells(3, 2)
Workbooks(FNO).Sheets(1).Cells(4, 2).Copy Workbooks(Fn1).Sheets(1).Cells(4, 2)
Workbooks(Fn1).Sheets(1).Cells(6, 1) = "Вопрос" ' Оформление конечного файла
Workbooks(Fn1).Sheets(1).Cells(7, 1) = "Кол-во"
Workbooks(Fn1).Sheets(1).Cells(8, 1) = "Ri"
Workbooks(Fn1).Sheets(1).Cells(9, 1) = "Ri/N"
Workbooks(Fn1).Sheets(1).Cells(11, 1) = "Вопрос"
Workbooks(Fn1).Sheets(1).Cells(12, 1) = "Кол-во"
Workbooks(Fn1).Sheets(1).Cells(13, 1) = "Ri"
Workbooks(Fn1).Sheets(1).Cells(14, 1) = "Ri/N"
Workbooks(Fn1).Sheets(1).Cells(17, 1) = "Вопрос"
Workbooks(Fn1).Sheets(1).Cells(17, 2) = "Кол-во"
Workbooks(Fn1).Sheets(1).Cells(17, 3) = "Ri"
Workbooks(Fn1).Sheets(1).Cells(17, 4) = "Ri/N"
Workbooks(Fn1).Sheets(1).Cells(17, 7) = "Кол-во"
Workbooks(Fn1).Sheets(1).Cells(17, 8) = "Процент"
n1 = 2
n = CountOfUsers ' Количество учащихся в группе
' Копирование данных а текущий файл
k = 1
For i = 1 To CountOfSheets
For j = 1 To 256
If j = 255 Then k = 0
If Workbooks(FNO).Sheets(i).Cells(n + 1 + 6, j + k) > 0 Then Workbooks(FNO).Sheets(i).Cells(n + 1 + 6, j + k).Copy _
Workbooks(Fn1).Sheets(1).Cells(7, n1)
If Workbooks(FNO).Sheets(i).Cells(n + 1 + 6, j + k) > 0 Then Workbooks(FNO).Sheets(i).Cells(6, j + k).Copy _
Workbooks(Fn1).Sheets(1).Cells(6, n1)
If Workbooks(FNO).Sheets(i).Cells(n + 1 + 6, j + k) > 0 Then Workbooks(FNO).Sheets(i).Cells(n + 2 + 6, j + k).Copy _
Workbooks(Fn1).Sheets(1).Cells(8, n1)
If Workbooks(FNO).Sheets(i).Cells(n + 1 + 6, j + k) > 0 Then n1 = n1 + 1
Next j
Next i
n1 = n1 - 1 - 7
For i = n1 + 2 To 256
Workbooks(Fn1).Sheets(1).Cells(6, i).Clear
Next i
For i = 2 To n1 + 1
q1 = Workbooks(Fn1).Sheets(1).Cells(6, i)
q2 = Workbooks(Fn1).Sheets(1).Cells(7, i)
q3 = Workbooks(Fn1).Sheets(1).Cells(8, i)
Workbooks(Fn1).Sheets(1).Cells(11, i) = Workbooks(Fn1).Sheets(1).Cells(6, n1 + 3 - i)
Workbooks(Fn1).Sheets(1).Cells(12, i) = Workbooks(Fn1).Sheets(1).Cells(7, n1 + 3 - i)
Workbooks(Fn1).Sheets(1).Cells(13, i) = Workbooks(Fn1).Sheets(1).Cells(8, n1 + 3 - i)
Workbooks(Fn1).Sheets(1).Cells(11, n1 + 3 - i) = q1
Workbooks(Fn1).Sheets(1).Cells(12, n1 + 3 - i) = q2
Workbooks(Fn1).Sheets(1).Cells(13, n1 + 3 - i) = q3
Next i
For i = 2 To n1 + 1
Workbooks(Fn1).Sheets(1).Cells(9, i) = Workbooks(Fn1).Sheets(1).Cells(8, i) / Workbooks(Fn1).Sheets(1).Cells(7, i)
Workbooks(Fn1).Sheets(1).Cells(14, i) = Workbooks(Fn1).Sheets(1).Cells(13, i) / Workbooks(Fn1).Sheets(1).Cells(12, i)
Next i
For i = 1 To n1
Workbooks(Fn1).Sheets(1).Cells(11, i + 1).Copy Workbooks(Fn1).Sheets(1).Cells(17 + i, 1)
Workbooks(Fn1).Sheets(1).Cells(12, i + 1).Copy Workbooks(Fn1).Sheets(1).Cells(17 + i, 2)
Workbooks(Fn1).Sheets(1).Cells(13, i + 1).Copy Workbooks(Fn1).Sheets(1).Cells(17 + i, 3)
Workbooks(Fn1).Sheets(1).Cells(17 + i, 4) = Workbooks(Fn1).Sheets(1).Cells(17 + i, 3) / Workbooks(Fn1).Sheets(1).Cells(17 + i, 2)
Next i
For i = 0 To 9
Workbooks(Fn1).Sheets(1).Cells(18 + i, 7) = 0
Workbooks(Fn1).Sheets(1).Cells(18 + i, 8) = (i + 1) * 10
Next i
For i = 1 To n1
If Workbooks(Fn1).Sheets(1).Cells(17 + i, 4) = 0 Then Workbooks(Fn1).Sheets(1).Cells(18, 7) = Workbooks(Fn1).Sheets(1).Cells(18, 7) + Workbooks(Fn1).Sheets(1).Cells(17 + i, 2)
Next i
For j = 0 To 9 Step 1
For i = 1 To n1
If Workbooks(Fn1).Sheets(1).Cells(17 + i, 4) > j * 0.1 And Workbooks(Fn1).Sheets(1).Cells(17 + i, 4) <= (j + 1) * 0.1 Then _
Workbooks(Fn1).Sheets(1).Cells(18 + j, 7) = Workbooks(Fn1).Sheets(1).Cells(18 + j, 7) + Workbooks(Fn1).Sheets(1).Cells(17 + i, 2)
Next i
Next j
For i = 2 To n1 + 1
Workbooks(Fn1).Sheets(1).Cells(9, i) = Format(Workbooks(Fn1).Sheets(1).Cells(9, i), "0.00%")
Workbooks(Fn1).Sheets(1).Cells(14, i) = Format(Workbooks(Fn1).Sheets(1).Cells(14, i), "0.00%")
Workbooks(Fn1).Sheets(1).Cells(16 + i, 4) = Format(Workbooks(Fn1).Sheets(1).Cells(16 + i, 4), "0.00%")
Next i
Workbooks(FNO).Close SaveChanges:=False 'Закрытие рабочей книги с названием, соответствующим значению переменной FNO без сохранения изменений
EndTime = Timer
MsgBox "Выполнено за " & Format(EndTime - StartTime, "0.0") & " сек." 'Определение времени выполнения
End Sub
Приложение 2: Процедуры, используемые в программе
Public Function FileNameXLS() As String
'Импорт файла
Dim Filt As String
Dim FilterIndex As Integer
Dim FileName As Variant
Dim Title As String
'Настройка списка файлов
Filt = "Файлы Excel (*.xls),*.xls,"
'По умолчанию используется фильтр *.*
FilterIndex = 5
'Заголовок окна
Title = "Выберите импортируемый файл"
'Получение имени файла
FileName = Application.GetOpenFilename(filefilter:=Filt, FilterIndex:=FilterIndex, Title:=Title)
'При отмене - выйти из окна
If FileName = False Then
MsgBox "Файл не выбран"
FileNameXLS = " "
Exit Function
End If
'Отображение полного имени и пути
'MsgBox "Вы выбрали " & FileName
FileNameXLS = FileName
End Function
Private Function FileNameOnly(pname) As String
'Возвращает имя файла из пути/имени файла
FileNameOnly = Dir(pname)
End Function
Sub GreetMe4()
'Процедура для определения приветствия
If Time < 0.5 Then
MsgBox "Доброе утро" & ", выберите импортируемый файл"
Else
If Time >= 0.5 And Time < 0.75 Then
MsgBox "Добрый день" & ", выберите импортируемый файл"
Else
If Time >= 0.75 Then
MsgBox "Добрый вечер" & ", выберите импортируемый файл"
End If
End If
End If
End Sub
Function Num(File) As Integer
'Определение количества тестиреумых
Dim i As Integer
For i = 7 To 10000
If Workbooks(File).Sheets(1).Cells(i, 1).Value = "Кол-во" Then Exit Function
Num = Num + 1
Next i
End Function
Sub Diagr()
Application.ScreenUpdating = False
Charts.Add
ActiveChart.Location _
Where:=xlLocationAsObject, Name:="Лист1"
With ActiveChart
.SetSourceData Range("G18:H27")
.HasTitle = True
.ChartType = xl3DColumnClustered
.HasLegend = False
.ApplyDataLabels Type:=xlDataLabelsShowValue
.Axes(xlCategory).TickLabels.Orientation = xlHorizontal
.ChartTitle.Font.Bold = True
.ChartTitle.Font.Size = 12
.PlotArea.Top = 18
.PlotArea.Height = 162
.Axes(xlValue).MaximumScale = 0.6
.Deselect
End With
Application.ScreenUpdating = True
End Sub