Здравствуйте. Есть макрос который нормально работает. Но, я сам не понимаю зачем этот макрос не работает когда я добавляю его свой надстройку. Помогите пожалуйста. Заранее спасибо. примере module14
Код |
---|
Sub iSelectColumnForFilter() Dim i As Long Dim n As Integer Dim Criterij As String Dim iName As String Dim Sht As Worksheet Dim Sht_table As String Dim iLastCol As Integer Dim iSelectCol As Integer Dim iLastRow As Long Application.ScreenUpdating = False Application.DisplayAlerts = False 'îòêëþ÷åíèå ïðåäóïðåæäàþùèõ ñîîáùåíèé Sht_table = ActiveSheet.Name For Each Sht In ThisWorkbook.Worksheets 'óäàëÿåì âñå ëèñòû, êðîìå Sht_table If Sht.Name <> Sht_table Then Sht.Delete Next Application.DisplayAlerts = True iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column 'ïîñëåäíèé ñòîëáåö iSelectCol = Application.InputBox("Âûáåðèòå íîìåð ñòîëáöà ôèëüòðàöèè", Type:=1) If iSelectCol > iLastCol Then MsgBox "Âûáðàííûé ñòîëáåö âûõîäèò çà äèàïàçîí ñòîëáöîâ": Exit Sub Set Sht = ThisWorkbook.Worksheets(Sht_table) iLastRow = Cells(Rows.Count, 1).End(xlUp).Row Columns(iLastCol + 2).ClearContents Range(Cells(1, iSelectCol), Cells(iLastRow, iSelectCol)).AdvancedFilter Action:=xlFilterCopy _ , CopyToRange:=Cells(1, iLastCol + 2), Unique:=True n = Cells(Rows.Count, iLastCol + 2).End(xlUp).Row For i = 2 To n 'öèêë ïî óíèêàëüíûì çíà÷åíèÿì âûáðàííîãî ñòîëáöà Criterij = Sht.Cells(i, iLastCol + 2) iName = Criterij 'èìÿ íîâîãî ëèñòà Sht.Range(Sht.Cells(1, 1), Sht.Cells(iLastRow, iLastCol)).AutoFilter iSelectCol, Criterij Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy With Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'äîáàâëÿåò íîâûé ëèñò â êîíåö .Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteColumnWidths .Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteFormats .Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteValues Sht.AutoFilter.Range.AutoFilter .Name = iName .Range("A1").Select End With Next Application.ScreenUpdating = True Sht.Activate Columns(iLastCol + 2).ClearContents End Sub |