Как вставить несколько excel vba в один

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

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

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

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