Worksheets("Задачи").Activate rw = 7 Do Until Cells(rw, 1).Value = "" If InStr(1, UCase(Cells(rw, 13).Value), "архив", vbTextCompare) > 0 Then With Sheets("Архив") Rows(rw).Copy Destination:=.Rows(.Cells(Rows.Count, 1).End(xlUp).Row + 1) End With Rows(rw).Delete Else: rw = rw + 1 End If Loop End Sub
[/vba]
Сейчас приложу файл
StoTisteg, [vba]
Код
Sub Worksheet_Change()
Dim rw As Long
Worksheets("Задачи").Activate rw = 7 Do Until Cells(rw, 1).Value = "" If InStr(1, UCase(Cells(rw, 13).Value), "архив", vbTextCompare) > 0 Then With Sheets("Архив") Rows(rw).Copy Destination:=.Rows(.Cells(Rows.Count, 1).End(xlUp).Row + 1) End With Rows(rw).Delete Else: rw = rw + 1 End If Loop End Sub
_Boroda_, Я кажется нашел причину не срабатывания макроса. Он спотыкается о строки "Названия разделов" (выделены синим цветом). У них нет номера по порядку (может по этому) А вот как обойти - не умею =(
_Boroda_, Я кажется нашел причину не срабатывания макроса. Он спотыкается о строки "Названия разделов" (выделены синим цветом). У них нет номера по порядку (может по этому) А вот как обойти - не умею =(Anis625
Сообщение отредактировал Anis625 - Вторник, 19.06.2018, 16:51
Anis625, почистил Вам ужасный бардак в Условном форматировании. Много там удалил, кое-что переписал, кое-что добавил Переписал одинаковую для всех строк формулу в столбце 1 Убрал все ненужные макросы (на будущее - не нужно называть макрос в обычном модуле Worksheet_Change, это зарезервированное название макроса для модуля листа), нужные (один остался - Worksheet_BeforeDoubleClick) переписал. И заново написал макрос переноса в архив
[vba]
Код
Sub Arx() Dim d_ As Range Application.ScreenUpdating = 0 With Me If .AutoFilter.FilterMode Then .ShowAllData End If .ListObjects(1).Range.AutoFilter Field:=13, Criteria1:="Архив" With .AutoFilter.Range drk_ = 0 On Error Resume Next Set d_ = .Rows(2).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not d_ Is Nothing Then drk_ = d_.Cells.Count / d_.Columns.Count With Sheets("Архив") r1_ = .Cells(.Rows.Count, 1).End(xlUp).Row r0_ = 7 d_.Copy Destination:=.Cells(r1_ + 1, 1) .Cells.FormatConditions.Delete .Cells(r0_, 1).Resize(r1_ - r0_ + 1 + drk_).FormulaR1C1 = "=COUNT(R" & r0_ - 1 & "C:INDEX(C,ROW()-1))+1" End With Application.DisplayAlerts = 0 d_.Rows.Delete Application.DisplayAlerts = 1 End If End With .ShowAllData End With Application.ScreenUpdating = 1 MsgBox "В архив перенесено записей: " & drk_ End Sub
[/vba]
Anis625, почистил Вам ужасный бардак в Условном форматировании. Много там удалил, кое-что переписал, кое-что добавил Переписал одинаковую для всех строк формулу в столбце 1 Убрал все ненужные макросы (на будущее - не нужно называть макрос в обычном модуле Worksheet_Change, это зарезервированное название макроса для модуля листа), нужные (один остался - Worksheet_BeforeDoubleClick) переписал. И заново написал макрос переноса в архив
[vba]
Код
Sub Arx() Dim d_ As Range Application.ScreenUpdating = 0 With Me If .AutoFilter.FilterMode Then .ShowAllData End If .ListObjects(1).Range.AutoFilter Field:=13, Criteria1:="Архив" With .AutoFilter.Range drk_ = 0 On Error Resume Next Set d_ = .Rows(2).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not d_ Is Nothing Then drk_ = d_.Cells.Count / d_.Columns.Count With Sheets("Архив") r1_ = .Cells(.Rows.Count, 1).End(xlUp).Row r0_ = 7 d_.Copy Destination:=.Cells(r1_ + 1, 1) .Cells.FormatConditions.Delete .Cells(r0_, 1).Resize(r1_ - r0_ + 1 + drk_).FormulaR1C1 = "=COUNT(R" & r0_ - 1 & "C:INDEX(C,ROW()-1))+1" End With Application.DisplayAlerts = 0 d_.Rows.Delete Application.DisplayAlerts = 1 End If End With .ShowAllData End With Application.ScreenUpdating = 1 MsgBox "В архив перенесено записей: " & drk_ End Sub