Объединить несколько макросов в один макрос

@undefined7 · Регистрация: 22.01.2013

Студворк — интернет-сервис помощи студентам

Подскажите пожалуйста как объединить в один макрос несколько:

1 макрос.

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
Sub Consolidated_Range_of_Books_and_Sheets()
    Dim iBeginRange As Object, lCalc As Long, lCol As Long
    Dim oAwb As String, sCopyAddress As String, sSheetName As String
    Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
    On Error Resume Next
    '1. Выбираем диапазон выборки с книг
    Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
                                           "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _
                                           vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)
    '2. Если диапазон не выбран - завершаем процедуру
    If iBeginRange Is Nothing Then Exit Sub
    '3. Указываем имя листа
    '4. Допустимо указывать в имени листа символы подставки ? и *.
    'Если указать только * то данные будут собираться со всех листов
    sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
    '5. Если имя листа не указано - данные будут собраны со вех листов
    If sSheetName = "" Then sSheetName = "*"
    On Error GoTo 0
    '6. Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
    If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then
        avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
        If VarType(avFiles) = vbBoolean Then Exit Sub
        bPolyBooks = True
        lCol = 1
    Else
        avFiles = Array(ThisWorkbook.FullName)
    End If
    '7. отключаем обновление экрана, автопересчет формул и отслеживание событий
    'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
    End With
    Application.DisplayAlerts = False
    '8. создаем новый лист в книге для сбора после текущего листа After:=ActiveSheet либо в конец After:=Sheets(Sheets.Count)
    ThisWorkbook.Sheets.Add after:=ActiveSheet
    Set wsDataSheet = ThisWorkbook.ActiveSheet
    '9. цикл по книгам
    For li = LBound(avFiles) To UBound(avFiles)
        If bPolyBooks Then Workbooks.Open Filename:=avFiles(li)
        oAwb = Dir(avFiles(li), vbDirectory)
        '10. цикл по листам
        For Each wsSh In Workbooks(oAwb).Sheets
            If wsSh.Name Like sSheetName Then
                '11. Если имя листа совпадает с именем листа, в который собираем данные
                'и сбор идет только с активной книги - то переходим к следующему листу
                If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
                With wsSh
                    Select Case iBeginRange.Count
                    Case 1 '12. собираем данные начиная с указанной ячейки и до конца данных
                        lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
                        iLastColumn = .Cells.SpecialCells(xlLastCell).Column
                        sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
                    Case Else '13. собираем данные с фиксированного диапазона
                        sCopyAddress = iBeginRange.Address
                    End Select
                    lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
                    '14. вставляем имя книги, с которой собраны данные
                    If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = oAwb
                    .Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
                End With
            End If
NEXT_:
        Next wsSh
        If bPolyBooks Then Workbooks(oAwb).Close False
    Next li
    '15. переименовываем лист с данными
    ThisWorkbook.Worksheets(2).Name = "main"
    '16. включаем обратно то что отключали
    With Application
        lCalc = .Calculation
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic
    End With
    
    '1. На время работы кода для ускорения работы кода отключаем:
    'Обновление монитора.
    Application.ScreenUpdating = False
    'События.
    Application.EnableEvents = False
    '2. Переносим текущий лист его после листа 000 если он случайно находиться где-то в другом месте
    Sheets("main").Select
    Sheets("main").Move Before:=Sheets(2)
    '3. добавляем ещё 1 строку
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    '4. удаляем границы
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).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
    '5. очищаем содержимое
    Selection.ClearComments
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = False
    With Selection.Font
        .Name = "Franklin Gothic Book"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    '6. удаляем кавычки и пустые пробелы и переименовываем Рур и Укрнафту
    Cells.Replace What:="""", Replacement:="", LookAt:=xlPart, SearchOrder _
    :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="   ", Replacement:="", LookAt:=xlPart, SearchOrder _
    :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Rows("5:5").Select
    Selection.AutoFilter
    '8. вставляем название бренда в 1 колонке
    'Range("A6:A" & Cells(Rows.Count, 1).End(xlUp).Row).Select
    Range("A6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Formula = "=RC[21]"
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    '11. удаляем ненужные колонки
    Range("A6").Activate
    Selection.RowHeight = 13.2
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
    'Columns("Q:R").Select
    'Selection.Delete Shift:=xlToLeft
    Columns("V:V").Select
    Selection.Delete Shift:=xlToLeft
    Columns("Q:Q").ColumnWidth = 6
    Columns("R:R").ColumnWidth = 6
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Application.Caption = Empty

2. макрос

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Sub Udalenie_Pustyh_Strok()
'    Удаляем пустые строки с листа 
    FirstRow = ActiveSheet.UsedRange.Row
    LastRow = ActiveSheet.UsedRange.Rows.Count - 1 + ActiveSheet.UsedRange.Row
        For r = LastRow To FirstRow Step -1
            If Application.CountA(Rows(r)) = 0 Then
                Rows(r).Delete
            End If
        Next r
 
End Sub

3. макрос

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
Sub Procedure_1()
   '28. формирование листов по брендам
    'В константе указываем порядковый номер последнего листа,
    'который должен просматриваться макросом.
    'Это связано с тем, что в ходе работа коды в книгу
    'будут добавляться листы.
    Const mySheetCount As Long = 2
 
    Dim shSheet_1 As Excel.Worksheet
    Dim shLast As Excel.Worksheet
    Dim rngSearch As Excel.Range
    Dim rngFind As Excel.Range, myAddress As String
    Dim myLastRow_1 As Long, myLastRow_2 As Long
    Dim iSheet_1 As Long, jSheet As Long
 
    '1. На время работы кода для ускорения работы кода отключаем:
    'Обновление монитора.
    Application.ScreenUpdating = False
    'Пересчёт формул.
    Application.Calculation = xlCalculationManual
    'События.
    Application.EnableEvents = False
 
    '2. Даём листу "000" имя "shSheet_1".
    'Через это имя будем обращаться к этому листу.
    Set shSheet_1 = Worksheets("000")
 
    'Двигаемся по листу "000" по первому столбцу до первой пустой ячейки.
    'Начиаем двигаться с первой строки.
    iSheet_1 = 1
    Do While IsEmpty(shSheet_1.Cells(iSheet_1, "A")) = False
 
    '3. Чтобы код был проще, сразу создаём лист для текущей ячейки,
    'независимо от того, встретится текст из текущей ячейки на
    'просматриваемых листах или нет.
    'After:=Worksheets(Worksheets.Count) - это последний лист.
    'Одновременно, при создании листа, даём имя "shLast" листу.
    'Через это имя будем обращаться к листу.
        Set shLast = Worksheets.Add(after:=Worksheets(Worksheets.Count))
 
    '4. Даём имя листу в соответствии с данными из ячейки.
    'Только в данном случае нужно учитывать:
    '1) нет ли уже листа с таким именем;
    '2) содержит ли имя допустимые символы;
    '3) длина имени.
    'Я этого ничего не буду учитывать.
        shLast.Name = shSheet_1.Cells(iSheet_1, "A").Value
 
    '5. Подготавливаем номер строки, куда будут вставляться данные на новом листе.
        myLastRow_2 = 1
 
    'В цикле с "jSheet" проходимся по листам, которые надо обработать.
        For jSheet = 2 To mySheetCount Step 1
 
    'Буду использовать команду "Find" для поиска.
    '6. Задаю диапазон поиска, чтобы код работал быстрее и лишнее не просматривал.
    '6.1. Определяю последнюю строку с данными на текущем листе в столбце "A".
            myLastRow_1 = Worksheets(jSheet).Columns("A").Find(What:="?", _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    '6.2. Даю фрагменту листа, где нужно искать, имя "rngSearch".
    'Здесь вместо "A1" можно указать строку, с которой нужно искать.
            Set rngSearch = Worksheets(jSheet).Range("A1:A" & myLastRow_1)
 
    '7. Осуществляем поиск.
    'After:=rngSearch.Cells(rngSearch.Rows.Count, 1) - здесь указываем,
    'что поиск начинаем с последней ячейки. Это связано с тем, что поиск
    'начинается после указанной ячейки, чтобы данные брались в том порядке,
    'в котором они находятся на листе.
    'LookAt:=xlPart - поиск по частичному совпадению, например "Укрнафт".
            Set rngFind = rngSearch.Find(What:=CStr(shSheet_1.Cells(iSheet_1, "A").Value), _
                after:=rngSearch.Cells(rngSearch.Rows.Count, 1), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
 
    'Если слово не будет найдено, то в переменной "rngFind"
    'будет содержаться слово "Nothing".
            If rngFind Is Nothing Then
 
    'Переходим к следующему листу.
                GoTo metka
 
            End If
 
    'Если был результат поиска, то найденной ячейке даётся имя "rngFind".
    'Через это имя можно обращаться к найденной ячейке.
    '8. Запоминаем адрес ячейки, чтобы потом остановить поиск, дойдя до этой же ячейки.
            myAddress = rngFind.Address
 
    'Ведём поиск, пока не вернёмся к первой найденной ячейке.
            Do
 
    '9. Копируем строку на последний лист
                rngFind.EntireRow.Copy Destination:=shLast.Range("A" & myLastRow_2)
 
    '10. Подготавливаем номер строки на последнем листе для следующих данных.
                myLastRow_2 = myLastRow_2 + 1
 
    '11. Ищем дальше в том же диапазоне.
                Set rngFind = rngSearch.FindNext(rngFind)
 
            Loop While rngFind.Address <> myAddress
 
metka:
 
        Next jSheet
 
    '12. Переход к следующей строке.
        iSheet_1 = iSheet_1 + 1
 
    Loop
End Sub

4. макрос

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
Sub Procedure_2()
    
   
    'В константе указываете порядковый номер последнего
        'листа, который должен просматриваться макросом.
    'Это связано с тем, что в ходе работа коды в книгу
        'будут добавляться листы.
    Const mySheetCount As Long = 2
 
    Dim shSheet_1 As Excel.Worksheet
    Dim shLast As Excel.Worksheet
    Dim rngSearch As Excel.Range
    Dim rngFind As Excel.Range, myAddress As String
    Dim myLastRow_1 As Long, myLastRow_2 As Long
    Dim iSheet_1 As Long, jSheet As Long
    
    '1. На время работы кода для ускорения работы кода отключаем:
    'Обновление монитора.
    Application.ScreenUpdating = False
    'Пересчёт формул.
    Application.Calculation = xlCalculationManual
    'События.
    Application.EnableEvents = False
    
    '2. Даём листу "000" имя "shSheet_1".
    'Через это имя будем обращаться к этому листу.
    Set shSheet_1 = Worksheets("000")
    
    'Двигаемся по листу "000" по первому столбцу
    'до первой пустой ячейки.
    'Начиаем двигаться с первой строки.
    iSheet_1 = 1
    Do While IsEmpty(shSheet_1.Cells(iSheet_1, "C")) = False
    
    '3. Чтобы код был проще, сразу создаём лист для текущей ячейки,
    'независимо от того, встретится текст из текущей ячейки на
    'просматриваемых листах или нет.
    'After:=Worksheets(Worksheets.Count) - это последний лист.
    'Одновременно, при создании листа, даём имя "shLast" листу.
    'Через это имя будем обращаться к листу.
        Set shLast = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        
    '4. Даём имя листу в соответствии с данными из ячейки.
    'Только в данном случае нужно учитывать:
    '1) нет ли уже листа с таким именем;
    '2) содержит ли имя допустимые символы;
    '3) длина имени.
    'Я этого ничего не буду учитывать.
        shLast.Name = shSheet_1.Cells(iSheet_1, "C").Value
    
    '5. Подготавливаем номер строки, куда будут вставляться данные на новом листе.
        myLastRow_2 = 1
    
    'В цикле с "jSheet" проходимся по листам, которые надо обработать.
        For jSheet = 2 To mySheetCount Step 1
        
    'Буду использовать команду "Find" для поиска.
    '6. Задаю диапазон поиска, чтобы код работал быстрее и лишнее
    'не просматривал.
    '6.1. Определяю последнюю строку с данными на текущем листе
    'в столбце "T".
            myLastRow_1 = Worksheets(jSheet).Columns("W").Find(What:="?", _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    '6.2. Даю фрагменту листа, где нужно искать, имя "rngSearch".
    'Здесь вместо "T1" можно указать строку, с которой нужно искать.
            Set rngSearch = Worksheets(jSheet).Range("W1:W" & myLastRow_1)
            
    '7. Осуществляем поиск.
    'After:=rngSearch.Cells(rngSearch.Rows.Count, 1) - здесь указываем,
    'что поиск начинаем с последней ячейки. Это связано с тем, что поиск
    'начинается после указанной ячейки, чтобы данные брались в том порядке,
    'в котором они находятся на листе.
    'LookAt:=xlPart - поиск по частичному совпадению, например "Укрнафт".
            Set rngFind = rngSearch.Find(What:=CStr(shSheet_1.Cells(iSheet_1, "C").Value), _
                After:=rngSearch.Cells(rngSearch.rows.Count, 1), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
    'Если слово не будет найдено, то в переменной "rngFind"
    'будет содержаться слово "Nothing".
            If rngFind Is Nothing Then
            
    'Переходим к следующему листу.
                GoTo metka
            
            End If
            
    'Если был результат поиска, то найденной ячейке даётся имя "rngFind".
    'Через это имя можно обращаться к найденной ячейке.
    '8. Запоминаем адрес ячейки, чтобы потом остановить поиск,
    'дойдя до этой же ячейки.
            myAddress = rngFind.Address
            
    'Ведём поиск, пока не вернёмся к первой найденной ячейке.
            Do
            
    '9. Копируем строку на последний лист
                rngFind.EntireRow.Copy Destination:=shLast.Range("A" & myLastRow_2)
                
    '10. Подготавливаем номер строки на последнем листе для следующих данных.
                myLastRow_2 = myLastRow_2 + 1
                
    '11. Ищем дальше в том же диапазоне.
                Set rngFind = rngSearch.FindNext(rngFind)
                
            Loop While rngFind.Address <> myAddress
            
metka:
        
        Next jSheet
    
    '12. Переход к следующей строке.
        iSheet_1 = iSheet_1 + 1
        
    Loop
 
    '13. Включаем то, что отключали в начале работы кода.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
 
End Sub

@Hugo121 · 06.02.2013, 11:47

Не вникая в кучу строк - т.к. не видя файлы и задачу... вникать нерационально

Но попробуйте так:

Visual Basic
1
2
3
4
5
6
Sub ZapustiMenja()
Consolidated_Range_of_Books_and_Sheets
Udalenie_Pustyh_Strok
Procedure_1
Procedure_2
End sub

@undefined7 · 06.02.2013, 12:06 **[ТС]**

приложил файл

@Igor_Tr · 06.02.2013, 13:28

Здрасте! Если позволите.. Я бы убрал использование меток "Next_:". В цикле перебора можно установить ограничение (уточнение) на текущее использование книг/листов. Легче будет "разбирать полеты", мне кажется.

@sulfur · 06.02.2013, 14:20

Igor_Tr, вы это советуете человеку, который не может сам собрать несколько макросов в один?

@undefined7 · 06.02.2013, 14:53 **[ТС]**

Сообщение от Hugo121

... Но попробуйте так: ...

спасибо, воспользовался данной методикой - всё работает

@Igor_Tr · 06.02.2013, 14:55

to sulfur. Да нет. Это подсказка. Расшифровки легко найти в инете, у Harris, у Walkenbach. Совет звучал бы по другому. Например, при вызове процедуры из процедуры !!! советую использовать !!! служебное выражение Call НазваниеПроцедуры.

А так получается " по чайной ложке..." Думаю, лучьше сразу дать человеку повод задавать лишние вопросы по теме.

@undefined7 · 06.02.2013, 15:20 **[ТС]**

Сообщение от Igor_Tr

to sulfur. Да нет. Это подсказка. Расшифровки легко найти в инете, у Harris, у Walkenbach. Совет звучал бы по другому. Например, при вызове процедуры из процедуры !!! советую использовать !!! служебное выражение Call НазваниеПроцедуры.

А так получается " по чайной ложке..." Думаю, лучьше сразу дать человеку повод задавать лишние вопросы по теме.

именно это мне и нужно было, но подходит и последовательный запуск макросов, постараюсь обьязательно изучить ситуацию

@Igor_Tr · 06.02.2013, 15:55

Вы недопоняли

Hugo121 подсказал Вам все очень коректно и лаконинично. А я посоветовал только в его примере перед каждым названием вызываемой процедуры использовать "Call"

Visual Basic
1
2
3
4
Call Consolidated_Range_of_Books_and_Sheets
Call Udalenie_Pustyh_Strok
Call Procedure_1
Call Procedure_2

В результате: 1. Вам самому будет понятней где и что. 2. При больших проектах, забиваете в редакторе VBA в поиск только "Call" и быстро находите все места вставок/вызовов "подпроцедур". И т.д.
Одно только я не понял - за что мне "спасибо", когда инициатор этого всего Hugo121?

@Hugo121 · 06.02.2013, 16:53

Точно, поиск по call - это полезно. Нужно использовать...

@undefined7 · 06.02.2013, 18:20 **[ТС]**

Igor_Tr, почему-то при использовании функции call время выполнения увеличивается в 2 раза

@Igor_Tr · 06.02.2013, 23:38

Не должно бы. Буду дома - найду у себя что-нибудь протестировать.

Добавлено через 9 минут
И Ваш код даже на ходу не могу просмотреть. У меня 2003, *.xls. Но вот Select тут не меряно. Постарайтесь их все убрать.

Добавлено через 16 минут
Святая Мария! Присмотрелся! Попробуйте Rows(1).Insert ....
Потом:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).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
    '5. очищаем содержимое
    Selection.ClearComments
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With

Это все необходимо изменять - попробуйте, например:

Visual Basic
1
2
3
4
5
6
7
8
9
dim mRng as range
set mRng = Range(cells(a,b), cells(r,c))
with mRng
   .Borders(xlDiagonalDown).LineStyle = xlNone
    /////////////////////////////
   .Font.ColorIndex = xlAutomatic
   .Interior.Pattern = xlNone
    //// и т.д ///////
end with

Добавлено через 1 час 43 минуты
Проверил. В проекте 17 подпрограмм и 4 окна сообщения, плюс два окна ввода дат. До выдаления Call - 12 сек. После выдаления Call - 11 сек. Разница в секунду - думаю, за счет окон. А проек большой. Так-что причина где-то у Вас в коде или железке.
И где-то здесь на форуме (точно помню, что помогал мне Hugo) прогнал запись:

Visual Basic
1
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual

по сравнению с записью:

Visual Basic
1
2
3
.ScreenUpdating = False
 .EnableEvents = False
 .Calculation = xlManual

Вот тут точно могу сказать - вторая запись работает МНОГО быстрее!

Добавлено через 17 минут
Это тоже как-то тяжело для понимания:

Visual Basic
1
2
3
4
5
6
7
8
If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then
        avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
        If VarType(avFiles) = vbBoolean Then Exit Sub
        bPolyBooks = True
        lCol = 1
    Else
        avFiles = Array(ThisWorkbook.FullName)
    End If

Как понимаю я - все выбранные книги вы хотите загнать в массив. Правильно! Чтоб не писать, вытяну из моих файлов (Catstail помог):

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
 On Error Resume Next
    ' avFiles - это Ваша переменная Variant, и получаем массив
    avFiles= Application.GetOpenFilename _
            (" (*.xls),*.xls", , "Відкрити файли для обробки", , True)    ' _
                                        в цей масив записуємо всі дані файлів, _
                                                                        які хочемо відкрити .
        If Err = 13 Then Exit Sub ' Помилка, викликана _
                                                        відмовою від вибору файлів, _
                                                        тому зупиняємо процедуру. _
                                            13 - код помилки "Type mismatch" _
                                                        ( не відповідність типу даних)
        On Error GoTo 0

чтоб увидеть/понять что Вы записали:

Visual Basic
1
2
3
4
     dim i%, mStr$
     For i=Lbound(avFiles) To Ubound(avFiles)
         mstr=avFiles(i)
     Next 'i

А дальше работайте с этим массивом. Лично у меня дальше - используются словари (помощь Hugo121).

Добавлено через 1 час 58 минут
to undefined7. Немного подправлю:

Visual Basic
1
2
3
4
5
6
7
stop ' точка остановки выполнения автоматом. _
             Потом можно удалить. Дальше идем вручную F8. 
For i=Lbound(avFiles) To Ubound(avFiles)
    mstr=avFiles(i) ' Если курсор на mstr - высветит текущее значение
    'Нажимаете Ctrl + G - откроем окно Immediate
    debug.print avFiles(i) ' распечатает в Immediate 
Next 'i

И ради Всех Святых. Не нужно больше никаких "спасибо". Я и так в них сегодня - как Новогодняя елка

@undefined7 · 07.02.2013, 00:53 **[ТС]**

попробовал таким образом для ускорения:
удалил вообще -

Visual Basic
1
Application.DisplayAlerts = False

...

Visual Basic
1
Application.DisplayAlerts = True

а это записал так:

Visual Basic
1
2
3
4
    'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

потом в конце включил обратно:

Visual Basic
1
2
3
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

вроде бы работает быстрее немного

@sulfur · 07.02.2013, 09:39

Igor_Tr, запись в одну строчку через двоеточие работает медленнее, чем в несколько строчек?

@Igor_Tr · 07.02.2013, 12:19

Да, я сам был удивлен. Где-то здесь на форуме я задавал вопрос по Select (Offset несколько раз и без выделения). Небольшой листинг. Время в одну строчку - приблизительно 1.2 сек. Раскидано - 0.7 сек. Заметил случайно.

Добавлено через 5 минут
To undefined7. Здравствуйте. Все нормально. Поудаляйте еще по максимуму Select-ы - летать будет. Ну и там еще много есть лишнего.

@undefined7 · 07.02.2013, 14:43 **[ТС]**

а как тогда оптимизировать данный код, при этом не используя select

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
Sheets("Прочие").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Винница").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Волынь").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Днепр").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Донецк").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Житомир").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Закарпатье").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Запорожье").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Ив-Франковск").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Киев").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Кировоград").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Крым").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Луганск").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Львов").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Николаев").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Одесса").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Полтава").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Ровно").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Сумы").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Тернополь").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Харьков").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Херсон").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Хмельницкий").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Черкассы").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Чернигов").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    Sheets("Черновцы").Select
    Range("B6").Select
    ActiveWindow.FreezePanes = True
    Columns("A:A").ColumnWidth = 15.83
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("main").Select
    Range("A1").Select

и ещё, как в данном коде указать что, искать нужно по всей книге, а не только на текущем листе:

Visual Basic
1
2
3
4
'6. удаляем кавычки и пустые пробелы
    Cells.Replace What:="""", Replacement:="", LookAt:=xlPart, SearchOrder _
    :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="   ", Replacement:="", LookAt:=xlPart, SearchOrder _

@Igor_Tr · 07.02.2013, 15:32

Там, где Freeze - ничего не сделаете (а если - тогда нужен другой подход, например, оказаться от Freeze). А программе указать что-то взамен - например, прокрутить лист, что-бы было видно по окончании определенная часть листа.
По второму - попробуйте, к примеру, такое:

Visual Basic
1
2
3
4
5
6
7
8
9
10
dim mSheet as object
dim mCell as object
'Будем считать, что все НАЗВАНИЯ нужных книг залиты в дин. массив mBookArr() 
  for i=Lbound(mBookArr) to Ubound(mBookArr)
        for each mSheet in Workbooks(mBookArr(i)).Sheets
              for each mCell in mSheet.Cells
                   mCell=replace(mCell.value, "что меняем", "на что меняем", 1) 
              next
        next
  next 'i

Это так - развернуто. Модификаций может быть много.
И еще совет. Лучьше Вам начинать новые темы по конкретным вопросам. Больше вероятность того, что и другие подключатся. Умнее и опытнее меня.

Добавлено через 11 минут
Добавлю только, что ВСЕ ЭТО можно ограничить используемым диапазоном.

@undefined7 · 07.02.2013, 15:50 **[ТС]**

Сообщение от Igor_Tr

Там, где Freeze - ничего не сделаете (а если - тогда нужен другой подход, например, оказаться от Freeze). А программе указать что-то взамен - например, прокрутить лист, что-бы было видно по окончании определенная часть листа.
По второму - попробуйте, к примеру, такое:

Visual Basic
1
2
3
4
5
6
7
8
9
10
dim mSheet as object
dim mCell as object
'Будем считать, что все НАЗВАНИЯ нужных книг залиты в дин. массив mBookArr() 
  for i=Lbound(mBookArr) to Ubound(mBookArr)
        for each mSheet in Workbooks(mBookArr(i)).Sheets
              for each mCell in mSheet.Cells
                   mCell=replace(mCell.value, "что меняем", "на что меняем", 1) 
              next
        next
  next 'i

Это так - развернуто. Модификаций может быть много.
И еще совет. Лучьше Вам начинать новые темы по конкретным вопросам. Больше вероятность того, что и другие подключатся. Умнее и опытнее меня.

Добавлено через 11 минут
Добавлю только, что ВСЕ ЭТО можно ограничить используемым диапазоном.

не работает данный макрос , выдаёт ошибку на "i"

@Igor_Tr · 07.02.2013, 21:05

"i" английское? В массиве mBookArr хоть что-то есть? Дойдете до выражения

for i=Lbound(mBookArr) to Ubound(mBookArr)

установите курсор на Lbound, потом на Ubound - увидите размер массива mBookArr.
И, Езус Мария!, пожалуйста!, без "спасибо"!

Добавлено через 8 минут
А вобще, Вы обявили "i"? dim i as long? Редактор должен выдать причину ошибки!!!

Добавлено через 4 часа 42 минуты
Окрыл Ваш архив на работе. С одной стороны - все становится на места. С другой, чтоб Вам помочь, нужны какие-то данные. Киньте одну (лучьше две) книги с данными на листах и коротко обясните толком несколькими фразами, что нужно в конце. Раз уже ввязался - доделаю.

@Hugo121 · 07.02.2013, 22:31

Igor_Tr, про sheets/worksheets сегодня писал тут: Поиск одинаковых чисел в двух столбцах
Ваш код как иллюстрация

Хотя конечно не смертельно и скорее всего ошибки не будет. Но у меня разок было

Новые блоги и статьи Все статьи Все блоги /
PhpStorm 2025.3: WSL Terminal всегда стартует в ~ and_y87 14.12.2025 PhpStorm 2025. 3: WSL Terminal всегда стартует в ~ (home), игнорируя директорию проекта Симптом: После обновления до PhpStorm 2025. 3 встроенный терминал WSL открывается в домашней директории. . .	Access VikBal 11.12.2025 Помогите пожалуйста !! Как объединить 2 одинаковые БД Access с разными данными.	Новый ноутбук volvo 07.12.2025 Всем привет. По скидке в "черную пятницу" взял себе новый ноутбук Lenovo ThinkBook 16 G7 на Амазоне: Ryzen 5 7533HS 64 Gb DDR5 1Tb NVMe 16" Full HD Display Win11 Pro	Музыка, написанная Искусственным Интеллектом volvo 04.12.2025 Всем привет. Некоторое время назад меня заинтересовало, что уже умеет ИИ в плане написания музыки для песен, и, собственно, исполнения этих самых песен. Стихов у нас много, уже вышли 4 книги, еще 3. . .	От async/await к виртуальным потокам в Python IndentationError 23.11.2025 Армин Ронахер поставил под сомнение async/ await. Создатель Flask заявляет: цветные функции - провал, виртуальные потоки - решение. Не threading-динозавры, а новое поколение лёгких потоков. Откат?. . .
Поиск "дружественных имён" СОМ портов Argus19 22.11.2025 Поиск "дружественных имён" СОМ портов На странице: https:/ / norseev. ru/ 2018/ 01/ 04/ comportlist_windows/ нашёл схожую тему. Там приведён код на С++, который показывает только имена СОМ портов, типа,. . .	Сколько Государство потратило денег на меня, обеспечивая инсулином. Programma_Boinc 20.11.2025 Сколько Государство потратило денег на меня, обеспечивая инсулином. Вот решила сделать интересный приблизительный подсчет, сколько государство потратило на меня денег на покупку инсулинов. . . .	Ломающие изменения в C#.NStar Alpha Etyuhibosecyu 20.11.2025 Уже можно не только тестировать, но и пользоваться C#. NStar - писать оконные приложения, содержащие надписи, кнопки, текстовые поля и даже изображения, например, моя игра "Три в ряд" написана на этом. . .	Мысли в слух kumehtar 18.11.2025 Кстати, совсем недавно имел разговор на тему медитаций с людьми. И обнаружил, что они вообще не понимают что такое медитация и зачем она нужна. Самые базовые вещи. Для них это - когда просто люди. . .	Создание Single Page Application на фреймах krapotkin 16.11.2025 Статья исключительно для начинающих. Подходы оригинальностью не блещут. В век Веб все очень привыкли к дизайну Single-Page-Application . Быстренько разберем подход "на фреймах". Мы делаем одну. . .

@Igor_Tr 4377 / 661 / 36 Регистрация: 17.01.2010 Сообщений: 2,134
	06.02.2013, 13:28
	Здрасте! Если позволите.. Я бы убрал использование меток "Next_:". В цикле перебора можно установить ограничение (уточнение) на текущее использование книг/листов. Легче будет "разбирать полеты", мне кажется. 1

@sulfur 200 / 98 / 2 Регистрация: 24.09.2011 Сообщений: 261
	06.02.2013, 14:20
	Igor_Tr, вы это советуете человеку, который не может сам собрать несколько макросов в один? 1

@Igor_Tr 4377 / 661 / 36 Регистрация: 17.01.2010 Сообщений: 2,134
	06.02.2013, 14:55
	to sulfur. Да нет. Это подсказка. Расшифровки легко найти в инете, у Harris, у Walkenbach. Совет звучал бы по другому. Например, при вызове процедуры из процедуры !!! советую использовать !!! служебное выражение Call НазваниеПроцедуры. А так получается " по чайной ложке..." Думаю, лучьше сразу дать человеку повод задавать лишние вопросы по теме. 1

@Hugo121 6997 / 2895 / 555 Регистрация: 19.10.2012 Сообщений: 8,803
	06.02.2013, 16:53
	Точно, поиск по call - это полезно. Нужно использовать... 0

@undefined7 259 / 7 / 1 Регистрация: 22.01.2013 Сообщений: 47
	06.02.2013, 18:20 [ТС]
	Igor_Tr, почему-то при использовании функции call время выполнения увеличивается в 2 раза 0

@sulfur 200 / 98 / 2 Регистрация: 24.09.2011 Сообщений: 261
	07.02.2013, 09:39
	Igor_Tr, запись в одну строчку через двоеточие работает медленнее, чем в несколько строчек? 0

@Igor_Tr 4377 / 661 / 36 Регистрация: 17.01.2010 Сообщений: 2,134
	07.02.2013, 12:19
	Да, я сам был удивлен. Где-то здесь на форуме я задавал вопрос по Select (Offset несколько раз и без выделения). Небольшой листинг. Время в одну строчку - приблизительно 1.2 сек. Раскидано - 0.7 сек. Заметил случайно. Добавлено через 5 минут To undefined7. Здравствуйте. Все нормально. Поудаляйте еще по максимуму Select-ы - летать будет. Ну и там еще много есть лишнего. 1

@Hugo121 6997 / 2895 / 555 Регистрация: 19.10.2012 Сообщений: 8,803
	07.02.2013, 22:31
	Igor_Tr, про sheets/worksheets сегодня писал тут: Поиск одинаковых чисел в двух столбцах Ваш код как иллюстрация Хотя конечно не смертельно и скорее всего ошибки не будет. Но у меня разок было 1