Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.83/6: Рейтинг темы: голосов - 6, средняя оценка - 4.83
0 / 0 / 0
Регистрация: 17.02.2017
Сообщений: 13
1

Итоги в конце таблицы и преобразование в число данных

17.02.2017, 15:56. Показов 1084. Ответов 12
Метки нет (Все метки)

Есть файл, который выгружает система.
Т.к. книг с одинаковым содержимым много, то для удобства пользователя сделала загрузку содержимого через макрос. А дальше необходимо, что бы применялось условное форматирование в виде светофора и вниз таблицы добавлялись итоги. Сколько всего человек, сколько прошло тест и средние значения по результатам в%.
Где-то закралась ошибка и несколько смущает зависание в процессе преобразования данных в число. Помогите пожалуйста!

Данные в таблице Оценки

Сам макрос вот:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
Option Explicit
 
Sub bb()
    Dim FilesToOpen
    Dim x As Integer
    Dim importWB As Workbook, wb As Workbook
 
    Set wb = ActiveWorkbook
 
    Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
 
    'вызываем диалог выбора файлов для импорта
    FilesToOpen = Application.GetOpenFilename _
                  (FileFilter:="All files (*.*), *.*", _
                   MultiSelect:=True, Title:="Files to Merge")
 
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
 
    'проходим по всем выбранным файлам
    x = 1
    While x <= UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        importWB.Sheets().Copy After:=wb.Sheets(wb.Sheets.Count)
        importWB.Close savechanges:=False
        x = x + 1
    Wend
 
    Application.ScreenUpdating = True
    
    
'
' Светофор Макрос
'
 
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows("2:2").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("2:2").Select
    Columns("A:A").ColumnWidth = 37
    Columns("B:B").Select
    Selection.ColumnWidth = 12
    Columns("D:G").Select
    Selection.ColumnWidth = 24
    Columns("H:H").Select
    Selection.ColumnWidth = 15
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "ФИО"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "Таб.№"
    Range("C3").Select
    Selection.Copy
    Range("A1").Select
    ActiveSheet.Paste
    Columns("B:G").Select
    Selection.NumberFormat = "General"
    Selection.Value = Selection.Value
 
    
    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("A1:F2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
    Columns("C:F").Select
    Selection.FormatConditions.AddIconSetCondition
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .ReverseOrder = False
        .ShowIconOnly = False
        .IconSet = ActiveWorkbook.IconSets(xl3TrafficLights1)
    End With
    With Selection.FormatConditions(1).IconCriteria(2)
        .Type = xlConditionValueNumber
        .Value = 0.5
        .Operator = 7
    End With
    With Selection.FormatConditions(1).IconCriteria(3)
        .Type = xlConditionValueNumber
        .Value = 0.8
        .Operator = 7
    End With
 
Range("ТаблицаСВычислениями").Copy Cells(ActiveSheet.UsedRange.Rows.Count + 2, 1)
End Sub
0

Помощь в написании контрольных, курсовых и дипломных работ здесь.

Вложения
Тип файла: xlsx Оценки.xlsx (10.1 Кб, 4 просмотров)
Лучшие ответы (1)
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
17.02.2017, 15:56
Ответы с готовыми решениями:

Как в отчёте Access сделать так, чтобы итоги появлялись только в конце, а не после каждой записи?
Как в отчёте Access сделать так, чтобы итоги появлялись только в конце, а не после каждой записи?

Преобразование таблицы с многоуровневой структурой данных
Добрый день, столкнулся с такой проблемой: из 1С выгружаем отчет, данные в котором представляют...

Преобразование данных таблицы к классическому виду
ЗДравствуйте всем!Подскажите пожалуйста, можно ли с помощью запроса вывести данные из приложенной...

Преобразование таблицы с многоуровневой структурой данных - VBA
Всем доброго времени суток! Подскажите, пожалуйста, как решить задачу преобразования уровней из 1С...

12
3438 / 2103 / 698
Регистрация: 02.11.2012
Сообщений: 5,494
17.02.2017, 16:28 2
для отладки макроса есть волшебна кнопка F8.
открываете окно с кодом, ставите курсор внутри кода и жмете F8. происходит пошаговый проход по коду. смотрите на какой строке вылазит ошибка и разбираетесь с ней. Предварительно включите окно Locals в нем будут видны переменные и значения их на каждом шаге.
1
0 / 0 / 0
Регистрация: 17.02.2017
Сообщений: 13
17.02.2017, 16:30  [ТС] 3
Ошибки нет)) Просто смущает зависание в процессе преобразования в число. И мне кажется я некорректно нашла последнюю ячейку вставила в нее формулы.
0
6826 / 2768 / 520
Регистрация: 19.10.2012
Сообщений: 8,437
17.02.2017, 16:39 4
В данном случае с последней ячейкой порядок, можете проверить кодом
Visual Basic
1
ActiveSheet.UsedRange.Select
Но иногда бывает что выделится например с 10-й ячейки по 15-ю, и тогда конечно седьмая строка (ActiveSheet.UsedRange.Rows.Count + 2) будет совсем не под данными

Добавлено через 2 минуты
Вообще форматирование - процесс небыстрый...
Перенесите обновление экрана в конец кода.
1
0 / 0 / 0
Регистрация: 17.02.2017
Сообщений: 13
17.02.2017, 16:40  [ТС] 5
Вот снова прогоняю то, что нарисовала.
Зависает на моменте:
Visual Basic
1
2
Selection.NumberFormat = "General"
Selection.Value = Selection.Value
И кусок
Visual Basic
1
Range("ТаблицаСВычислениями").Copy Cells(ActiveSheet.UsedRange.Rows.Count + 2, 1)
Копирует не все ячейки с формулами, а всего одну первую и не подхватывает формат в процентах.
0
0 / 0 / 0
Регистрация: 17.02.2017
Сообщений: 13
17.02.2017, 16:43  [ТС] 6
Итог получается такой
0
Миниатюры
Итоги в конце таблицы и преобразование в число данных  
0 / 0 / 0
Регистрация: 17.02.2017
Сообщений: 13
24.02.2017, 17:44  [ТС] 7
Домучила я свой предыдущий макрос, теперь снова непонятка, помогите пожалуйста.
Нужно автоматически определить конец таблицы в листе "Оценки" и добавить туда итоги из листа "Итоги". Пробовала в теле макроса это прописать, хранить формулы показалось проще в отдельном листе. Но вот никак не перейду в нужный мне лист.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Sub Copy()
'
' Copy Макрос
    ActiveWorkbook.Sheets("Итоги").Select
    Range("A1:F3").Select
    Selection.Copy
    Cells(ActiveSheet.UsedRange.Rows.Count + 2, 1).Select
    ActiveSheet.Paste
    Cells(ActiveSheet.UsedRange.Rows.Count + 2, 1).Select
    Selection.FormatConditions.Delete
End Sub
0
Вложения
Тип файла: xlsx Оценки.xlsx (11.4 Кб, 4 просмотров)
6826 / 2768 / 520
Регистрация: 19.10.2012
Сообщений: 8,437
24.02.2017, 17:55 8
Не вижу в коде нигде копирования на лист "Оценки", нигде нет такого слова.
Скопировать легко, одна строка всего:
Visual Basic
1
Sheets("Итоги").[A1].CurrentRegion.Copy Sheets("Оценки").[A1].End(xlDown)(2)
1
0 / 0 / 0
Регистрация: 17.02.2017
Сообщений: 13
24.02.2017, 17:57  [ТС] 9
Я хотела не привязываться к имени листа "Оценки". Думала что если я стою в активном листе, то могу скопировать из лист:Итоги, табличку с формулами.
0
6826 / 2768 / 520
Регистрация: 19.10.2012
Сообщений: 8,437
24.02.2017, 18:01 10
Лучший ответ Сообщение было отмечено Tanochka как решение

Решение

P.S. И не надо никуда ходить...

Добавлено через 1 минуту
Можно не привязываться, раз уже стоите
Visual Basic
1
Sheets("Итоги").[A1].CurrentRegion.Copy ActiveSheet.[A1].End(xlDown)(2)
1
0 / 0 / 0
Регистрация: 17.02.2017
Сообщений: 13
24.02.2017, 18:05  [ТС] 11
Ой, пишет ошибку(( Туплю, да?

Subscript out of range (Error 9)
0
6826 / 2768 / 520
Регистрация: 19.10.2012
Сообщений: 8,437
24.02.2017, 18:15 12
Не знаю, не берусь судить
На примере отработало на 5.
1
0 / 0 / 0
Регистрация: 17.02.2017
Сообщений: 13
24.02.2017, 19:48  [ТС] 13
Работает! Идите я Вас расцелую!!!! Спасибо огромное!
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
24.02.2017, 19:48

Помощь в написании контрольных, курсовых и дипломных работ здесь.

Итоги у таблицы формы автоматом с отбором
зДРАВСТВУЙТЕ, ЕСТЬ ТАБЛИЦА ФОРМЫ, В НЕЙ СТОИТ ОТБОР, И СЧТИАЮТСЯ итоги по этой таблице. но...

Преобразование данных из строки в отрицательное число
Здравствуйте! Имеется ряд строк типа -498.67469 нужно преобразовать в число для дальнейшей...

Продублировать итоги первой таблицы на остальных листах
Добрый день! Есть такая ситуация, на первом листе имеется таблица-родоначальник (к примеру табл...

Преобразование данных из даты в число или наоборот
Здравствуйте. Возникла проблема: из экселя в базу аксесс загружается таблица, в которой есть...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
13
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.