Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Вставить строку с текстом над первой строкой со словом в яч - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставить строку с текстом над первой строкой со словом в яч (Макросы/Sub)
Вставить строку с текстом над первой строкой со словом в яч
Gjlhzl Дата: Воскресенье, 05.11.2023, 17:06 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 110
Репутация: 0 ±
Замечаний: 0% ±

День добрый, помогите подправить макрос:
--находит первое слово (список отсортирован и строк с определенным словом несколько) в столбце и в зависимости от его значения вставляет нан этой строкой строку с определенным текстом
"нарыл" макрос но он вставляет над всеми строками и как то не так...по сути нужно вставить наименования разделов строк

[vba]
Код
Sub Наименование_раздела()
Dim PS As Long
Dim i As Long
PS = Range("C" & Rows.Count).End(xlUp).Row
For i = PS To 2 Step -1
    If Cells(i, 3).Value Like "*РАЗБОР*" Then
    Rows(i - 1).Interior.ColorIndex = 15
    Rows(i - 1).Insert
    Cells(i - 1, 2) = "ДЕМОНТАЖНЫЕ РАБОТЫ"
    End If
Next
For i = PS To 2 Step -1
    If Cells(i, 3).Value Like "*СТЕН*" Then
    Rows(i - 1).Interior.ColorIndex = 15
    Rows(i - 1).Insert
    Cells(i - 1, 2) = "СТЕНЫ"
    End If
Next
For i = PS To 2 Step -1
    If Cells(i, 3).Value Like "*СТЯЖ*" Then
    Rows(i - 1).Interior.ColorIndex = 15
    Rows(i - 1).Insert
    Cells(i - 1, 2) = "ПОЛЫ"
    End If
Next

End Sub
[/vba]
К сообщению приложен файл: prim.xlsb (18.7 Kb)
 
Ответить
СообщениеДень добрый, помогите подправить макрос:
--находит первое слово (список отсортирован и строк с определенным словом несколько) в столбце и в зависимости от его значения вставляет нан этой строкой строку с определенным текстом
"нарыл" макрос но он вставляет над всеми строками и как то не так...по сути нужно вставить наименования разделов строк

[vba]
Код
Sub Наименование_раздела()
Dim PS As Long
Dim i As Long
PS = Range("C" & Rows.Count).End(xlUp).Row
For i = PS To 2 Step -1
    If Cells(i, 3).Value Like "*РАЗБОР*" Then
    Rows(i - 1).Interior.ColorIndex = 15
    Rows(i - 1).Insert
    Cells(i - 1, 2) = "ДЕМОНТАЖНЫЕ РАБОТЫ"
    End If
Next
For i = PS To 2 Step -1
    If Cells(i, 3).Value Like "*СТЕН*" Then
    Rows(i - 1).Interior.ColorIndex = 15
    Rows(i - 1).Insert
    Cells(i - 1, 2) = "СТЕНЫ"
    End If
Next
For i = PS To 2 Step -1
    If Cells(i, 3).Value Like "*СТЯЖ*" Then
    Rows(i - 1).Interior.ColorIndex = 15
    Rows(i - 1).Insert
    Cells(i - 1, 2) = "ПОЛЫ"
    End If
Next

End Sub
[/vba]

Автор - Gjlhzl
Дата добавления - 05.11.2023 в 17:06
WowGun Дата: Воскресенье, 05.11.2023, 21:02 | Сообщение № 2
Группа: Проверенные
Ранг: Новичок
Сообщений: 27
Репутация: 3 ±
Замечаний: 0% ±

Я бы пошел другим путем

[vba]
Код

Sub bob()
PS = Range("C" & Rows.Count).End(xlUp).Row

t = Cells(2, 3)

If t <> "" Then
    Rows(2).Insert
    Range("A2:C2").Interior.ColorIndex = 15
    If t Like "*РАЗБОР*" Then
        p = "ДЕМОНТАЖНЫЕ РАБОТЫ"
        
    ElseIf t Like "*СТЕН*" Then
        p = "СТЕНЫ"
        
    ElseIf t Like "*СТЯЖ*" Then
        p = "ПОЛЫ"
    
    End If
    
    Cells(2, 2) = p
    PS = PS + 1
End If

For i = 3 To PS
    t1 = Cells(i, 3)
    If t1 <> t Then
        Rows(i).Insert
        Range("A" & i & ":C" & i).Interior.ColorIndex = 15
        
        If t1 Like "*РАЗБОР*" Then
        p = "ДЕМОНТАЖНЫЕ РАБОТЫ"
        
    ElseIf t1 Like "*СТЕН*" Then
        p = "СТЕНЫ"
        
    ElseIf t1 Like "*СТЯЖ*" Then
        p = "ПОЛЫ"
    
    End If
        
        Cells(i, 2) = p
        PS = PS + 1
        t = t1
    End If
Next

End Sub
[/vba]


Сообщение отредактировал WowGun - Воскресенье, 05.11.2023, 21:07
 
Ответить
СообщениеЯ бы пошел другим путем

[vba]
Код

Sub bob()
PS = Range("C" & Rows.Count).End(xlUp).Row

t = Cells(2, 3)

If t <> "" Then
    Rows(2).Insert
    Range("A2:C2").Interior.ColorIndex = 15
    If t Like "*РАЗБОР*" Then
        p = "ДЕМОНТАЖНЫЕ РАБОТЫ"
        
    ElseIf t Like "*СТЕН*" Then
        p = "СТЕНЫ"
        
    ElseIf t Like "*СТЯЖ*" Then
        p = "ПОЛЫ"
    
    End If
    
    Cells(2, 2) = p
    PS = PS + 1
End If

For i = 3 To PS
    t1 = Cells(i, 3)
    If t1 <> t Then
        Rows(i).Insert
        Range("A" & i & ":C" & i).Interior.ColorIndex = 15
        
        If t1 Like "*РАЗБОР*" Then
        p = "ДЕМОНТАЖНЫЕ РАБОТЫ"
        
    ElseIf t1 Like "*СТЕН*" Then
        p = "СТЕНЫ"
        
    ElseIf t1 Like "*СТЯЖ*" Then
        p = "ПОЛЫ"
    
    End If
        
        Cells(i, 2) = p
        PS = PS + 1
        t = t1
    End If
Next

End Sub
[/vba]

Автор - WowGun
Дата добавления - 05.11.2023 в 21:02
Gjlhzl Дата: Понедельник, 06.11.2023, 09:12 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 110
Репутация: 0 ±
Замечаний: 0% ±

WowGun, спасибо, работает!
 
Ответить
СообщениеWowGun, спасибо, работает!

Автор - Gjlhzl
Дата добавления - 06.11.2023 в 09:12
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставить строку с текстом над первой строкой со словом в яч (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!