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

Вход

Регистрация

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

 

= Мир MS Excel/перенос значений из одной в другую ячейку по условию - Мир MS Excel

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

Excel 2013
Здравствуйте. Помогите написать макрос. нужно при нажатии кнопки, проверялись ячейки В2:B12 на предмет наличия в них буквы "о". если ее нет, то в C2:C12 записывается - "долг", а также значения из левых ячеек будут заносится в D18:D26, а дата из шапки в E18:E26. Заранее благодарен.
К сообщению приложен файл: 4864679.xlsx(12Kb)
 
Ответить
СообщениеЗдравствуйте. Помогите написать макрос. нужно при нажатии кнопки, проверялись ячейки В2:B12 на предмет наличия в них буквы "о". если ее нет, то в C2:C12 записывается - "долг", а также значения из левых ячеек будут заносится в D18:D26, а дата из шапки в E18:E26. Заранее благодарен.

Автор - logush2083
Дата добавления - 30.11.2017 в 00:39
китин Дата: Четверг, 30.11.2017, 07:55 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4442
Репутация: 701 ±
Замечаний: 0% ±

Excel 2007;Excel 2010
Здравствуйте
как то так
[vba]
Код
Sub TTT()
Dim lr&, i&
lr = Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Cells(Rows.Count, 4).End(xlUp).Row
  On Error Resume Next
  Range("D18:E" & lr2).ClearContents
    For i = 2 To lr
        Cells(i, 3).ClearContents
        If Cells(i, 2).Value <> "о" And Cells(i, 1).Value <> "" Then
        Cells(i, 3).Value = "Долг"
        lr1 = Cells(Rows.Count, 4).End(xlUp).Row
        Cells(lr1 + 1, 4).Value = Cells(i, 1).Value
        Cells(lr1 + 1, 5).Value = Cells(1, 1).Value
        End If
    Next i
End Sub
[/vba]
К сообщению приложен файл: logush2083.xlsm(16Kb)


Не судите строго:я пытаюсь научиться
ЯД 41001877306852/WM R249698041931; Z239672726538


Сообщение отредактировал китин - Четверг, 30.11.2017, 08:01
 
Ответить
СообщениеЗдравствуйте
как то так
[vba]
Код
Sub TTT()
Dim lr&, i&
lr = Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Cells(Rows.Count, 4).End(xlUp).Row
  On Error Resume Next
  Range("D18:E" & lr2).ClearContents
    For i = 2 To lr
        Cells(i, 3).ClearContents
        If Cells(i, 2).Value <> "о" And Cells(i, 1).Value <> "" Then
        Cells(i, 3).Value = "Долг"
        lr1 = Cells(Rows.Count, 4).End(xlUp).Row
        Cells(lr1 + 1, 4).Value = Cells(i, 1).Value
        Cells(lr1 + 1, 5).Value = Cells(1, 1).Value
        End If
    Next i
End Sub
[/vba]

Автор - китин
Дата добавления - 30.11.2017 в 07:55
_Boroda_ Дата: Четверг, 30.11.2017, 09:22 | Сообщение № 3
Группа: Модераторы
Ранг: Местный житель
Сообщений: 11852
Репутация: 4911 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
У меня такой вариант
[vba]
Код
Sub tt()
    na_ = Range("A" & Rows.Count).End(3).Row - 1
    If na_ = 0 Then Exit Sub
    rd1_ = Range("D" & Rows.Count).End(3).Row
    rd0_ = 18
    dat_ = Range("A1")
    If rd1_ < rd0_ Then
        rd1_ = rd0_
    Else
        Range("D" & rd0_).Resize(rd1_ - rd0_ + 1, 2).ClearContents
    End If
    ar1 = Range("A2").Resize(na_, 3)
    ar2 = Range("A2").Resize(na_, 2)
    For i = 1 To na_
        If ar1(i, 2) <> "о" And ar1(i, 1) <> "" Then
            n_ = n_ + 1
            ar1(i, 3) = "долг"
            ar2(n_, 1) = ar1(i, 1)
            ar2(n_, 2) = dat_
        End If
    Next i
    Range("D" & rd0_).Resize(n_, 2) = ar2
    Range("A2").Resize(na_, 3) = ar1
End Sub
[/vba]
К сообщению приложен файл: 4864679_1.xlsm(19Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеУ меня такой вариант
[vba]
Код
Sub tt()
    na_ = Range("A" & Rows.Count).End(3).Row - 1
    If na_ = 0 Then Exit Sub
    rd1_ = Range("D" & Rows.Count).End(3).Row
    rd0_ = 18
    dat_ = Range("A1")
    If rd1_ < rd0_ Then
        rd1_ = rd0_
    Else
        Range("D" & rd0_).Resize(rd1_ - rd0_ + 1, 2).ClearContents
    End If
    ar1 = Range("A2").Resize(na_, 3)
    ar2 = Range("A2").Resize(na_, 2)
    For i = 1 To na_
        If ar1(i, 2) <> "о" And ar1(i, 1) <> "" Then
            n_ = n_ + 1
            ar1(i, 3) = "долг"
            ar2(n_, 1) = ar1(i, 1)
            ar2(n_, 2) = dat_
        End If
    Next i
    Range("D" & rd0_).Resize(n_, 2) = ar2
    Range("A2").Resize(na_, 3) = ar1
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 30.11.2017 в 09:22
logush2083 Дата: Четверг, 30.11.2017, 18:33 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Огромное ЧЕЛОВЕЧЕСКОЕ СПАСИБО ВАМ. Ни хера в этом не понимаю,, но работает. Не могли бы Вы прокоментировать строки,, это только пример и мне Ваш код надо будет доделать. Или помогите, таких шапок с датами 30, соответственно и столбцы присутствуют с разными значениями. Долги - три колонки по три столбца, этого хватает при ручном введении.
 
Ответить
СообщениеОгромное ЧЕЛОВЕЧЕСКОЕ СПАСИБО ВАМ. Ни хера в этом не понимаю,, но работает. Не могли бы Вы прокоментировать строки,, это только пример и мне Ваш код надо будет доделать. Или помогите, таких шапок с датами 30, соответственно и столбцы присутствуют с разными значениями. Долги - три колонки по три столбца, этого хватает при ручном введении.

Автор - logush2083
Дата добавления - 30.11.2017 в 18:33
_Boroda_ Дата: Пятница, 01.12.2017, 09:11 | Сообщение № 5
Группа: Модераторы
Ранг: Местный житель
Сообщений: 11852
Репутация: 4911 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Анатолий, предположу, что переделка имеющегося кода на несколько шапок будет не так проста. Вы лучше положите реальный файл (кстати, сколько там строк?) или его кусок, но только обрезанный по строкам, а не по столбцам. Ну и конф. данные на что-нибудь похожее (не на а,б,в,... ) замените


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеАнатолий, предположу, что переделка имеющегося кода на несколько шапок будет не так проста. Вы лучше положите реальный файл (кстати, сколько там строк?) или его кусок, но только обрезанный по строкам, а не по столбцам. Ну и конф. данные на что-нибудь похожее (не на а,б,в,... ) замените

Автор - _Boroda_
Дата добавления - 01.12.2017 в 09:11
logush2083 Дата: Пятница, 01.12.2017, 17:10 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Вот. здесь все на что я был способен. не поставил кнопку. Вы увидите что почти все в ручную. и поэтому бывают ошибки при поиске не заполненых ячеек "о".
К сообщению приложен файл: logushl.xlsm(37Kb)


Сообщение отредактировал logush2083 - Пятница, 01.12.2017, 17:13
 
Ответить
СообщениеВот. здесь все на что я был способен. не поставил кнопку. Вы увидите что почти все в ручную. и поэтому бывают ошибки при поиске не заполненых ячеек "о".

Автор - logush2083
Дата добавления - 01.12.2017 в 17:10
_Boroda_ Дата: Понедельник, 04.12.2017, 10:26 | Сообщение № 7
Группа: Модераторы
Ранг: Местный житель
Сообщений: 11852
Репутация: 4911 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Анатолий, что-то в файле Вашем последнем как-то запутано все. Явно требуются пояснения Ваши


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеАнатолий, что-то в файле Вашем последнем как-то запутано все. Явно требуются пояснения Ваши

Автор - _Boroda_
Дата добавления - 04.12.2017 в 10:26
Мир MS Excel » Вопросы и решения » Вопросы по VBA » перенос значений из одной в другую ячейку по условию (Макросы/Sub)
Страница 1 из 11
Поиск:

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