Есть код который удаляет все пустые строки, нужно если должность 1 и ФИО заполнено чтобы не удалялось

@Sh0ck3r · Регистрация: 17.09.2019

Студворк — интернет-сервис помощи студентам

Привет всем!) Есть код который удаляет все пустые строки, он работает. Нужно если должность одна и ФИО заполнено чтобы не удалялось. Сейчас чистится даже если ФИО заполнено и одна строка. Спасибо заранее!

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
Private Sub CommandButton34_Click()
Application.ScreenUpdating = False
     ActiveSheet.Unprotect (159) 'снимается пароль
       Application.Calculation = xlManual 'Отключение автоматических перерасчетов
  Dim countRow, Rowcount As Integer
  If MsgBox("Вы уверены что хотите удалить ВСЕ пустые строки?", vbYesNo) = vbYes Then
     countRow = ActiveSheet.UsedRange.Rows.Count
     Do While countRow >= 8
        Rowcount = ActiveSheet.Range("C" & countRow - (Rowcount - 1)).MergeArea.Rows.Count
        If Rowcount > 1 Then
           If ActiveSheet.Range("C" & countRow - (Rowcount - 1)).Value = "" Then
              ActiveSheet.Rows(countRow - (Rowcount - 1) & ":" & countRow).Select
              Selection.Delete Shift:=xlUp
              countRow = ActiveSheet.UsedRange.Rows.Count
              ActiveSheet.Range("C8").Select
           Else
              countRow = countRow - Rowcount
           End If
        Else
          countRow = countRow - 1
        End If
     Loop
     Call CommandButton35_Click
     ActiveSheet.Protect Password:=159, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                         AllowFormattingColumns:=True, AllowFormattingRows:=True
  Application.ScreenUpdating = True
  End If
End Sub

@elixi · 06.10.2020, 02:04

Sh0ck3r, попробуйте.
Надеюсь, ничего не перепутал.

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
Private Sub CommandButton34_Click()
Dim dRange As Range, delArea As Range
Dim RowLast As Long, i As Long, dRwF As Long, dRwL As Long
Dim KolDolzn As Byte
 
If MsgBox("Вы уверены что хотите удалить ВСЕ пустые строки?", vbYesNo) = vbYes Then
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect (159) 'снимается пароль
    Application.Calculation = xlManual 'Отключение автоматических перерасчетов
        
    With ActiveWorkbook.ActiveSheet
        RowLast = .Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious).Row
        For i = RowLast To 8 Step -1
            '   если понял правильно, удаляем всегда четыре строки вместе
            If .Cells(i, "C").MergeArea.Rows.Count = 4 Then
                dRwF = .Cells(i, "C").MergeArea(1).Row
                dRwL = i        'dRwF + .Cells(i, "C").MergeArea.Rows.Count - 1
                '   считаем количество должностей
                Set dRange = .Range("D" & dRwF & ":D" & dRwL)
                KolDolzn = Application.WorksheetFunction.CountA(dRange)
                '   если в столбце "C" данные, и количество должностей = 1, строки оставляем
                If .Cells(i, "C").MergeArea(1) <> "" And KolDolzn = 1 Then
                Else
                '   если нет, загоняем в Range Collection для следующего позже удаления строк
                    If delArea Is Nothing Then
                        Set delArea = Range(dRwF & ":" & dRwL)
                    Else
                        Set delArea = Union(delArea, .Range(dRwF & ":" & dRwL))
                    End If
                End If
                i = dRwF    '   понижаем счетчик для избежания не нужной работы
            End If
        Next
                '   удаляем строки
                If Not delArea Is Nothing Then delArea.Delete
    End With
    
    Application.Goto ActiveSheet.Range("A1"), True
    'Call CommandButton35_Click
    ActiveSheet.Protect Password:=159, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
    AllowFormattingColumns:=True, AllowFormattingRows:=True
    Application.ScreenUpdating = True
End If
End Sub

@Sh0ck3r · 06.10.2020, 09:21 **[ТС]**

Спасибо, но немного не то. Нужно чтобы если ФИО заполнено, то чтобы оставляло в независимости от кол-ва должностей. А если должность одна и ФИО не заполнено, то удалить.

@elixi · 06.10.2020, 10:51

Сообщение от Sh0ck3r

Спасибо, но немного не то.

макрoс рабoтает пo этoму услoвию:

Сообщение от Sh0ck3r

Нужно если должность одна и ФИО заполнено чтобы не удалялось.

этo услoвие уже другoе:

Сообщение от Sh0ck3r

Нужно чтобы если ФИО заполнено, то чтобы оставляло в независимости от кол-ва должностей. А если должность одна и ФИО не заполнено, то удалить.

не беда, мoжнo исправить, нo есть ещё вариант: если должности две и ФИО не заполнено, то чтo делать?

@Sh0ck3r · 06.10.2020, 10:59 **[ТС]**

тоже удалять) Любые строки где ничего нет в столбце С, в независимости от кол-ва должностей должно чистить. Если столбец с ФИО не заполнен, то чистить все должности.
Есть еще такой код, здесь нужно цикл задать через While:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub CommandButton34_Click()
Application.ScreenUpdating = False
     ActiveSheet.Unprotect (159) 'снимается пароль
       Application.Calculation = xlManual 'Отключение автоматических перерасчетов
 Dim rF As Range
 Dim lLastRow As Long
  If MsgBox("Вы уверены что хотите удалить ВСЕ пустые строки?", vbYesNo) = vbYes Then
    Set rF = ActiveSheet.UsedRange.FindNext("*", , , , xlByRows, xlPrevious)
    If rF Is Nothing Then
        lLastRow = rF.Row
        Rows.Delete (lLastRow)
    End If
    Loop
     Call CommandButton35_Click
     ActiveSheet.Protect Password:=159, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                         AllowFormattingColumns:=True, AllowFormattingRows:=True
  Application.ScreenUpdating = True
  End If
End Sub

Добавлено через 5 минут
Может этот код даже и проще, только я туплю как цикл запустить.

@elixi · 06.10.2020, 11:00

тoгда пoпрoбуйте:

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
Private Sub CommandButton34_Click()
Dim dRange As Range, delArea As Range
Dim RowLast As Long, i As Long, dRwF As Long, dRwL As Long
Dim KolDolzn As Byte
 
If MsgBox("Вы уверены что хотите удалить ВСЕ пустые строки?", vbYesNo) = vbYes Then
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect (159) 'снимается пароль
    Application.Calculation = xlManual 'Отключение автоматических перерасчетов
        
    With ActiveWorkbook.ActiveSheet
        RowLast = .Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious).Row
        For i = RowLast To 8 Step -1
            '   если понял правильно, удаляем всегда четыре строки вместе
            If .Cells(i, "C").MergeArea.Rows.Count = 4 Then
                dRwF = .Cells(i, "C").MergeArea(1).Row
                dRwL = i        'dRwF + .Cells(i, "C").MergeArea.Rows.Count - 1
                '   считаем количество должностей
                'Set dRange = .Range("D" & dRwF & ":D" & dRwL)
                'KolDolzn = Application.WorksheetFunction.CountA(dRange)
                '   если в столбце "C" данные, строки оставляем
                If .Cells(i, "C").MergeArea(1) <> "" Then
                Else
                '   если нет, загоняем в Range Collection для следующего позже удаления строк
                    If delArea Is Nothing Then
                        Set delArea = Range(dRwF & ":" & dRwL)
                    Else
                        Set delArea = Union(delArea, .Range(dRwF & ":" & dRwL))
                    End If
                End If
                i = dRwF    '   понижаем счетчик для избежания не нужной работы
            End If
        Next
                '   удаляем строки
                If Not delArea Is Nothing Then delArea.Delete
    End With
    
    Application.Goto ActiveSheet.Range("A1"), True
    'Call CommandButton35_Click
    ActiveSheet.Protect Password:=159, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
    AllowFormattingColumns:=True, AllowFormattingRows:=True
    Application.ScreenUpdating = True
End If
End Sub

@Sh0ck3r · 06.10.2020, 11:03 **[ТС]**

сейчас если 1 должность и ФИО не заполнено, не удаляет(

@elixi · 06.10.2020, 11:31

Сообщение от Sh0ck3r

сейчас если 1 должность и ФИО не заполнено, не удаляет(

вечерoм пoсмoтрю...

@Sh0ck3r · 06.10.2020, 11:47 **[ТС]**

Хорошо, но даже за это уже огромное спасибо!)

@Sh0ck3r · 06.10.2020, 12:07 **[ТС]**

У меня есть еще 1 косяк. Есть кнопка добавление строки, если стоишь на столбце с ФИО, то добавляет нового человека. Если на должности, то добавляет новую строку. Но если стоишь на верхней должности и нажимаешь кнопку, то получается вот такая фигня:

@Sh0ck3r · 06.10.2020, 12:08 **[ТС]**

1ый скрин не то) Нужно чтобы когда выбрана верхняя должность писало ошибку или чтобы добавляло вниз. С тем я разобрался) Все работает, спасибо!!!

@Sh0ck3r · 06.10.2020, 12:17 **[ТС]**

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub CommandButton9_Click()
  ActiveSheet.Unprotect (159) 'снимается пароль
  Application.Calculation = xlManual 'Отключение автоматических перерасчетов
  Application.ScreenUpdating = False
       With ActiveSheet
      .Rows(ActiveCell.Row & ":" & ActiveCell.Row + (.Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Rows.Count - 1)).Copy
      .Rows(ActiveCell.Row & ":" & ActiveCell.Row + (.Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Rows.Count - 1)).Insert Shift:=xlDown
  End With
  Call CommandButton35_Click
  ActiveSheet.Protect Password:=159, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                      AllowFormattingColumns:=True, AllowFormattingRows:=True
  Application.ScreenUpdating = True
End Sub

@elixi · 07.10.2020, 00:18

Sh0ck3r, не знаю понял ли я чего хотите достич. Попробуйте и отпишитесь правильно ли это работает:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Sub CommandButton9_Click()
  ActiveSheet.Unprotect (159) 'снимается пароль
  Application.Calculation = xlManual 'Отключение автоматических перерасчетов
  Application.ScreenUpdating = False
       With ActiveSheet
      .Cells(ActiveCell.Row, "C").Activate
      .Rows(ActiveCell.Row & ":" & ActiveCell.Row + (.Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Rows.Count - 1)).Copy
      .Rows(ActiveCell.Row & ":" & ActiveCell.Row + (.Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Rows.Count - 1)).Insert Shift:=xlDown
  End With
  Call CommandButton35_Click
  ActiveSheet.Protect Password:=159, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                      AllowFormattingColumns:=True, AllowFormattingRows:=True
  Application.ScreenUpdating = True
End Sub

@Sh0ck3r · 07.10.2020, 08:18 **[ТС]**

Вообще теперь не работает( Нужно чтобы если выбрана верхняя должность, то добавлять вниз.

@elixi · 07.10.2020, 21:58

Сообщение от Sh0ck3r

Вообще теперь не работает

Неработает? Это не так. Вы, наверно, невнимательно смотрели. Теперь, вне зависимости от того который столбец активный, "C", "D" или какой-нибудь другой, процедура сделает копию всех четырёх строк - добавит четыре новые и вставит в них данные из прежде активной четвёрки строк.

@Sh0ck3r · 08.10.2020, 08:11 **[ТС]**

Так не нужно, нужно чтобы добавлялась 3я должность у того же человека. Их может быть до 5

@elixi · 08.10.2020, 21:44

Sh0ck3r, я ответил вам здесь:
Есть код который добавляет строку с объединенными ячейками, работает только если выбрана нижняя строка
не знаю зачем повторяете ваши вопросы в новых темах, да ещё не со всей информацией

Новые блоги и статьи Все статьи Все блоги /
К слову об оптимизации kumehtar 01.04.2026 Вспоминаю начало 2000-х, университет, когда я писал на Delphi. Тогда среди программистов на форумах активно обсуждали аккуратную работу с памятью: нужно было следить за переменными, вовремя. . .	Идея фильтра интернета (сервер = слой+фильтр). Hrethgir 31.03.2026 Суть идеи заключается в том, чтобы запустить свой сервер, о чём я если честно мечтал давно и давно приобрёл книгу как это сделать. Но не было причин его запускать. Очумелые учёные напечатали на. . .	Модель здравосоХранения 6. ESG-повестка и устойчивое развитие; углублённый анализ кадрового бренда anaschu 31.03.2026 В прикрепленном документе раздумья о том, как можно поменять модель в будущем	10 пpимет, которые всегда сбываются Maks 31.03.2026 1. Чтобы, наконец, пришла маршрутка, надо закурить. Если сигарета последняя, маршрутка придет еще до второй затяжки даже вопреки расписанию. 2. Нaдоели зима и снег? Не надо переезжать. Достаточно. . .
Перемещение выделенных строк ТЧ из одного документа в другой Maks 31.03.2026 Реализация из решения ниже выполнена на примере нетипового документа "ВыдачаОборудованияНаСпецтехнику" с единственной табличной частью "ОборудованиеИКомплектующие" разработанного в конфигурации КА2. . . .	Functional First Web Framework Suave DevAlt 30.03.2026 Sauve. IO Апнулись до NET10. Из зависимостей один пакет, работает одинаково хорошо как в режиме проекта так и в интерактивном режиме. из сложностей - чисто функциональный подход. Решил. . .	Автоматическое создание документа при проведении другого документа Maks 29.03.2026 Реализация из решения ниже выполнена на нетиповых документах, разработанных в конфигурации КА2. Есть нетиповой документ "ЗаявкаНаРемонтСпецтехники" и нетиповой документ "ПланированиеСпецтехники". В. . .	Настройка движения справочника по регистру сведений Maks 29.03.2026 Решение ниже реализовано на примере нетипового справочника "ТарифыМобильнойСвязи" разработанного в конфигурации КА2, с целью учета корпоративной мобильной связи в коммерческом предприятии. . . .

@Sh0ck3r 0 / 0 / 0 Регистрация: 17.09.2019 Сообщений: 90
	06.10.2020, 09:21 [ТС]
	Спасибо, но немного не то. Нужно чтобы если ФИО заполнено, то чтобы оставляло в независимости от кол-ва должностей. А если должность одна и ФИО не заполнено, то удалить. 0

@Sh0ck3r 0 / 0 / 0 Регистрация: 17.09.2019 Сообщений: 90
	06.10.2020, 11:03 [ТС]
	сейчас если 1 должность и ФИО не заполнено, не удаляет( 0

@Sh0ck3r 0 / 0 / 0 Регистрация: 17.09.2019 Сообщений: 90
	06.10.2020, 11:47 [ТС]
	Хорошо, но даже за это уже огромное спасибо!) 0

@Sh0ck3r 0 / 0 / 0 Регистрация: 17.09.2019 Сообщений: 90
	06.10.2020, 12:07 [ТС]
	У меня есть еще 1 косяк. Есть кнопка добавление строки, если стоишь на столбце с ФИО, то добавляет нового человека. Если на должности, то добавляет новую строку. Но если стоишь на верхней должности и нажимаешь кнопку, то получается вот такая фигня: Миниатюры 0

@Sh0ck3r 0 / 0 / 0 Регистрация: 17.09.2019 Сообщений: 90
	06.10.2020, 12:08 [ТС]
	1ый скрин не то) Нужно чтобы когда выбрана верхняя должность писало ошибку или чтобы добавляло вниз. С тем я разобрался) Все работает, спасибо!!! Миниатюры 0

@Sh0ck3r 0 / 0 / 0 Регистрация: 17.09.2019 Сообщений: 90
	07.10.2020, 08:18 [ТС]
	Вообще теперь не работает( Нужно чтобы если выбрана верхняя должность, то добавлять вниз. 0

@Sh0ck3r 0 / 0 / 0 Регистрация: 17.09.2019 Сообщений: 90
	08.10.2020, 08:11 [ТС]
	Так не нужно, нужно чтобы добавлялась 3я должность у того же человека. Их может быть до 5 0

@elixi 349 / 190 / 108 Регистрация: 01.04.2020 Сообщений: 538
	08.10.2020, 21:44
	Sh0ck3r, я ответил вам здесь: Есть код который добавляет строку с объединенными ячейками, работает только если выбрана нижняя строка не знаю зачем повторяете ваши вопросы в новых темах, да ещё не со всей информацией 0

Есть код который удаляет все пустые строки, нужно если должность 1 и ФИО заполнено чтобы не удалялось

Решение