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

Вход

Регистрация

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

 

= Мир MS Excel/Создание и заполнение ячеек - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание и заполнение ячеек (Макросы/Sub)
Создание и заполнение ячеек
zaknafein Дата: Понедельник, 30.05.2016, 14:53 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте. Помогите пожалуйста с решением проблемы... Задача следующая: есть файл, в нем несколько столбцов. В столбце Получатель возможен вариант с разделителем "," (КС.КИП,СС,ЭТО,ВиК). Нужно если встречается такая запись, ниже вставить строку, все столбцы должны быть заполнены, как в строке где встретилась эта запись и в столбце Получатель заполнить одним из значений, например, КС.КИП. В файле выделил желтым как должно получиться. Начальную строку удалить. Спасибо.


Сообщение отредактировал zaknafein - Вторник, 31.05.2016, 07:36
 
Ответить
СообщениеЗдравствуйте. Помогите пожалуйста с решением проблемы... Задача следующая: есть файл, в нем несколько столбцов. В столбце Получатель возможен вариант с разделителем "," (КС.КИП,СС,ЭТО,ВиК). Нужно если встречается такая запись, ниже вставить строку, все столбцы должны быть заполнены, как в строке где встретилась эта запись и в столбце Получатель заполнить одним из значений, например, КС.КИП. В файле выделил желтым как должно получиться. Начальную строку удалить. Спасибо.

Автор - zaknafein
Дата добавления - 30.05.2016 в 14:53
Karataev Дата: Понедельник, 30.05.2016, 15:52 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 837
Репутация: 312 ±
Замечаний: 0% ±

Excel
[vba]
Код
Sub jjj()

    Dim arr(), arrCom
    Dim lr As Long, i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    lr = Columns("H").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr() = Range("H1:H" & lr).Value
    
    For i = UBound(arr) To 2 Step -1
        arrCom = Split(arr(i, 1), ",")
        If UBound(arrCom) > 0 Then
            Rows(i).Copy
            Rows(i + 1).Resize(UBound(arrCom)).Insert
            For j = 0 To UBound(arrCom)
                Cells(i + j, "H").Value = arrCom(j)
            Next
        End If
    Next

    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True

End Sub
[/vba]


 
Ответить
Сообщение[vba]
Код
Sub jjj()

    Dim arr(), arrCom
    Dim lr As Long, i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    lr = Columns("H").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr() = Range("H1:H" & lr).Value
    
    For i = UBound(arr) To 2 Step -1
        arrCom = Split(arr(i, 1), ",")
        If UBound(arrCom) > 0 Then
            Rows(i).Copy
            Rows(i + 1).Resize(UBound(arrCom)).Insert
            For j = 0 To UBound(arrCom)
                Cells(i + j, "H").Value = arrCom(j)
            Next
        End If
    Next

    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True

End Sub
[/vba]

Автор - Karataev
Дата добавления - 30.05.2016 в 15:52
Roman777 Дата: Понедельник, 30.05.2016, 15:53 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 748
Репутация: 81 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
zaknafein, у Вас в примере ошибка? или я логики ещё не уловил. Почему 3 доп строки получилось, если у Вас через "запятую" было 4 выражения ('КС.КИП,СС,ЭТО,ВиК): "КС.КИП", "СС", "ЭТО", "ВиК"...


Много чего не знаю!!!!
 
Ответить
Сообщениеzaknafein, у Вас в примере ошибка? или я логики ещё не уловил. Почему 3 доп строки получилось, если у Вас через "запятую" было 4 выражения ('КС.КИП,СС,ЭТО,ВиК): "КС.КИП", "СС", "ЭТО", "ВиК"...

Автор - Roman777
Дата добавления - 30.05.2016 в 15:53
sboy Дата: Понедельник, 30.05.2016, 17:44 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 601
Репутация: 156 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код
Sub obrabotka()
Dim ir As Integer
Dim stext As String
Dim chek As Boolean

ir = Cells(Rows.Count, 1).End(xlUp).Row
For q = ir To 2 Step -1
stext = Cells(q, 8).Value
chek = stext Like "*,*"
If chek = True Then
k = 1
For x = 1 To Len(stext)
If Mid(stext, x, 1) = "," Then k = k + 1
Next x
n = 1
r = q
For w = 1 To k
p = InStr(n, stext, ",", vbTextCompare)
If p = 0 Then p = Len(stext) + 1
Rows(r).Copy
Rows(r).Insert (xlShiftDown)

Cells(r, 8).Value = Mid(stext, n, p - n)
n = p + 1
r = r + 1
Next w
Rows(r).Delete xlShiftUp
End If
Next q
End Sub
[/vba]
 
Ответить
Сообщение[vba]
Код
Sub obrabotka()
Dim ir As Integer
Dim stext As String
Dim chek As Boolean

ir = Cells(Rows.Count, 1).End(xlUp).Row
For q = ir To 2 Step -1
stext = Cells(q, 8).Value
chek = stext Like "*,*"
If chek = True Then
k = 1
For x = 1 To Len(stext)
If Mid(stext, x, 1) = "," Then k = k + 1
Next x
n = 1
r = q
For w = 1 To k
p = InStr(n, stext, ",", vbTextCompare)
If p = 0 Then p = Len(stext) + 1
Rows(r).Copy
Rows(r).Insert (xlShiftDown)

Cells(r, 8).Value = Mid(stext, n, p - n)
n = p + 1
r = r + 1
Next w
Rows(r).Delete xlShiftUp
End If
Next q
End Sub
[/vba]

Автор - sboy
Дата добавления - 30.05.2016 в 17:44
zaknafein Дата: Вторник, 31.05.2016, 07:33 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
zaknafein, у Вас в примере ошибка? или я логики ещё не уловил. Почему 3 доп строки получилось, если у Вас через "запятую" было 4 выражения ('КС.КИП,СС,ЭТО,ВиК): "КС.КИП", "СС", "ЭТО", "ВиК"...

Да, ошибка.

Спасибо большое, Karataev и sboy. все работает как надо.
 
Ответить
Сообщение
zaknafein, у Вас в примере ошибка? или я логики ещё не уловил. Почему 3 доп строки получилось, если у Вас через "запятую" было 4 выражения ('КС.КИП,СС,ЭТО,ВиК): "КС.КИП", "СС", "ЭТО", "ВиК"...

Да, ошибка.

Спасибо большое, Karataev и sboy. все работает как надо.

Автор - zaknafein
Дата добавления - 31.05.2016 в 07:33
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание и заполнение ячеек (Макросы/Sub)
Страница 1 из 11
Поиск:

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