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

@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 сегодня писал тут: Поиск одинаковых чисел в двух столбцах
Ваш код как иллюстрация

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

Новые блоги и статьи Все статьи Все блоги /
Отчёт о спецтехнике находящейся в ремонте Maks 20.04.2026 Отчёт из решения ниже размещен в конфигурации КА2. Задача: отобразить спецтехнику, которая на данный момент находится в ремонте. Есть нетиповой документ "Заявка на ремонт спецтехники" который. . .	Памятка для бота и "визитка" для читателей "Semantic Universe Layer (Слой семантической вселенной)" Hrethgir 19.04.2026 Сгенерировано для краткого описания по случаю сборки и компиляции скелета серверного приложения. И пусть после этого скажут, что статьи сгенерированные AI - туфта и не интересно. И это не реклама -. . .	Запрет удаления строк ТЧ документа при определенном условии Maks 19.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "Аккумуляторы", разработанного в конфигурации КА2. У данного документа есть ТЧ, в которой в зависимости от прав доступа. . .	Модель заражения группы наркоманов alhaos 17.04.2026 Условия задачи сформулированы тут Суть: - Группа наркоманов из 10 человек. - Только один инфицирован ВИЧ. - Колются одной иглой. - Колются раз в день. - Колются последовательно через. . .
Мысли в слух. Про "навсегда". kumehtar 16.04.2026 Подумалось тут, что наверное очень глупо использовать во всяких своих установках понятие "навсегда". Это очень сильное понятие, и я только начинаю понимать край его смысла, не смотря на то что давно. . .	My Business CRM MaGz GoLd 16.04.2026 Всем привет, недавно возникла потребность создать CRM, для личных нужд. Собственно программа предоставляет из себя базу данных клиентов, в которой можно фиксировать звонки, стадии сделки, а также. . .	Знаешь почему 90% людей редко бывают счастливыми? kumehtar 14.04.2026 Потому что они ждут. Ждут выходных, ждут отпуска, ждут удачного момента. . . а удачный момент так и не приходит.	Фиксация колонок в отчете СКД Maks 14.04.2026 Фиксация колонок в СКД отчета типа Таблица. Задача: зафиксировать три левых колонки в отчете. Процедура ПриКомпоновкеРезультата(ДокументРезультат, ДанныеРасшифровки, СтандартнаяОбработка) / / . . .

@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 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	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 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	07.02.2013, 22:31
	Igor_Tr, про sheets/worksheets сегодня писал тут: Поиск одинаковых чисел в двух столбцах Ваш код как иллюстрация Хотя конечно не смертельно и скорее всего ошибки не будет. Но у меня разок было 1