Excel макрос перемещение по листам

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

Sub Кнопка2_Щелчок()
 Dim rng As Range, x: Application.ScreenUpdating = False
    x = "100%"
    If Sheets("Лист 1").[G:G].Find(x) Is Nothing Then Exit Sub
    With Sheets("Архив")
        .Cells.ClearContents
        Sheets("Лист 1").UsedRange.Copy .[A1]
.[G:G].ColumnDifferences(.[G:G].Find(x)).EntireRow.Delete
       End With
       
       
 
With Sheets("Отдел ПТО")
        Dim ra As Range, delra As Range, Текстдляпоиска As String
    Application.ScreenUpdating = False
 
    Текстдляпоиска = "100%"
 
    For Each ra In ActiveSheet.UsedRange.Rows
        
        If Not ra.Find(Текстдляпоиска, , xlValues, xlPart) Is Nothing Then
           
            If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
        End If
    Next
    If Not delra Is Nothing Then delra.EntireRow.Delete
    End With
    
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

Option Explicit
Sub mmm()
   Dim aa, ff, aaDel, ii2, ii, nCols, nRows
   Const HdrRows = 1 'Число строк заголовка - поставьте сюда СВОЁ
   With Sheets(1).UsedRange
     nCols = .Columns().Count + .Column - 1 'число колонок на первой тсранице
     nRows = .Rows().Count + .Row - 1 'Число строк на первой странице
   End With
   ReDim ff(nCols - 1) ' массив форматов ячеек
   With Sheets(1)
     For ii = 0 To nCols - 1 Step 1
       ff(ii) = .Cells(HdrRows + 1, ii + 1).NumberFormat 'считаем форматы первой строки данных после заголовка
     Next
     aa = .Cells(1, 1).Resize(nRows, nCols).Value 'Считаем все данные с 1 страницы
   End With
   If Sheets.Count < 2 Then ' Если 2 страницы нет - добавим
     Sheets.Add , Sheets(1), 1
     With Sheets(2)
       .Name = "ИТОГО" 'название 2 страницы
       .Cells(1, 1).Resize(HdrRows, nCols).Value = aa 'заголовок перенесем
       For ii = 1 To nCols Step 1
         .Columns(ii).NumberFormat = ff(ii - 1) 'форматы зададим сразу колонкам
       Next
     End With
   End If
   ReDim aaDel(UBound(aa) - 1) 'массив номеров переносимых и удаляемых строк
   ii2 = 0 ' число переносимых и удаляемых строк
   For ii = HdrRows + 1 To nRows Step 1 ' по всем строкам ниже заголовка
     If aa(ii, 7) >= 1# Then ' Если в G:G больше или равно 100%
       aaDel(ii2) = ii 'записываем номер строки в массив удаляемых
       ii2 = ii2 + 1 ' увеличиваеам число переносимых и удаляемых строк
     End If
   Next
   If ii2 > 0 Then 'Если есть что переносить
     nRows = ii2 ' 
     ReDim Preserve aaDel(nRows - 1)
     For ii2 = 1 To nRows Step 1 'для каждой удаляемой строки
       For ii = 1 To nCols Step 1
          aa(ii2, ii) = aa(aaDel(ii2 - 1), ii) 'переносим её в начало массива данных
       Next
     Next
   End If
' записываем данные после последней строки на 2 листе (форматы уже перенесли ранее для столбцов)   
   Sheets(2).Cells(Sheets(2).UsedRange.Rows.Count + Sheets(2).UsedRange.Row, 1).Resize(nRows, nCols).Value = aa
   For ii2 = nRows To 1 Step -1
     Sheets(1).Rows(aaDel(ii2 - 1)).Delete 'удаляем строки снизу вверх на первой странице
   Next
End Sub

1

MsgBox "В архив перенесено " & nRows & " строк"

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

Option Explicit
Sub mmm()
   Dim aa, ff, aaDel, ii2, ii, nCols, nRows
   Const HdrRows = 1 'Число строк заголовка - поставьте сюда СВОЁ
   With Sheets(1).UsedRange
     nCols = .Columns().Count + .Column - 1 'число колонок на первой тсранице
     nRows = .Rows().Count + .Row - 1 'Число строк на первой странице
   End With
   ReDim ff(nCols - 1) ' массив форматов ячеек
   With Sheets(1)
     For ii = 0 To nCols - 1 Step 1
       ff(ii) = .Cells(HdrRows + 1, ii + 1).NumberFormat 'считаем форматы первой строки данных после заголовка
     Next
     aa = .Cells(1, 1).Resize(nRows, nCols).Value 'Считаем все данные с 1 страницы
   End With
   If Sheets.Count < 2 Then ' Если 2 страницы нет - добавим
     Sheets.Add , Sheets(1), 1
     With Sheets(2)
       .Name = "ИТОГО" 'название 2 страницы
       .Cells(1, 1).Resize(HdrRows, nCols).Value = aa 'заголовок перенесем
       For ii = 1 To nCols Step 1
         .Columns(ii).NumberFormat = ff(ii - 1) 'форматы зададим сразу колонкам
       Next
     End With
   End If
   ReDim aaDel(UBound(aa) - 1) 'массив номеров переносимых и удаляемых строк
   ii2 = 0 ' число переносимых и удаляемых строк
   For ii = HdrRows + 1 To nRows Step 1 ' по всем строкам ниже заголовка
     If aa(ii, 7) >= 1# Then ' Если в G:G больше или равно 100%
       aaDel(ii2) = ii 'записываем номер строки в массив удаляемых
       ii2 = ii2 + 1 ' увеличиваеам число переносимых и удаляемых строк
     End If
   Next
   If ii2 > 0 Then 'Если есть что переносить
     nRows = ii2 ' 
     ReDim Preserve aaDel(nRows - 1)
     For ii2 = 1 To nRows Step 1 'для каждой удаляемой строки
       For ii = 1 To nCols Step 1
          aa(ii2, ii) = aa(aaDel(ii2 - 1), ii) 'переносим её в начало массива данных
       Next
     Next
' записываем данные после последней строки на 2 листе (форматы уже перенесли ранее для столбцов)   
     Sheets(2).Cells(Sheets(2).UsedRange.Rows.Count + Sheets(2).UsedRange.Row, 1).Resize(nRows, nCols).Value = aa
     For ii2 = nRows-1 To 0 Step -1
       Sheets(1).Rows(aaDel(ii2)).Delete 'удаляем строки снизу вверх на первой странице
     Next
     MsgBox "В архив перенесено " & nRows & " строк"
   Else
     MsgBox "Нечего переносить"
   End If
End Sub