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

Вход

Регистрация

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

 

= Мир MS Excel/Копировать значения из 3 столбцов в 1 по порядку с пропускам - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копировать значения из 3 столбцов в 1 по порядку с пропускам (Макросы/Sub)
Копировать значения из 3 столбцов в 1 по порядку с пропускам
Serg_naum Дата: Суббота, 02.12.2017, 13:11 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
Есть задача: на листе "Свод" есть таблица в которой есть три столбца (выделил зеленым), из которых нужно выбрать значения до последнего входящего и скопировать их на новый лист "Заполнить" в ячейку D3 по порядку (сначала из столбца B и до конца, потом из F, потом из J).
При этом в столбцах (кроме столбца B) могут быть пропуски.
Пробовал записью макроса, но не пойму как в том столбце куда вставлять выбирать последнее значение, после которого нужно вставлять.
Пример во вложении.

Заранее благодарен.
К сообщению приложен файл: 2046280.xlsx (22.3 Kb)
 
Ответить
СообщениеДобрый день.
Есть задача: на листе "Свод" есть таблица в которой есть три столбца (выделил зеленым), из которых нужно выбрать значения до последнего входящего и скопировать их на новый лист "Заполнить" в ячейку D3 по порядку (сначала из столбца B и до конца, потом из F, потом из J).
При этом в столбцах (кроме столбца B) могут быть пропуски.
Пробовал записью макроса, но не пойму как в том столбце куда вставлять выбирать последнее значение, после которого нужно вставлять.
Пример во вложении.

Заранее благодарен.
Автор - Serg_naum
Дата добавления - 02.12.2017 в 13:11
Kuzmich Дата: Суббота, 02.12.2017, 13:57 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация: 156 ±
Замечаний: 0% ±

Excel 2003
Запускать при активном листе "Свод"
[vba]
Код
Sub Tablica()
Dim iLastRow As Long
Dim iLR As Long
Dim j As Integer
Dim MyArr
   MyArr = Array(1, 6, 10)
With Worksheets("Заполнить")
   .Columns("D").ClearContents
   .Cells(3, 4) = "Код"
   For j = 0 To UBound(MyArr)
    iLastRow = Cells(Rows.Count, MyArr(j)).End(xlUp).Row
       iLR = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
       Range(Cells(2, MyArr(j)), Cells(iLastRow, MyArr(j))).Copy .Cells(iLR, 4)
   Next
End With
End Sub
[/vba]
 
Ответить
СообщениеЗапускать при активном листе "Свод"
[vba]
Код
Sub Tablica()
Dim iLastRow As Long
Dim iLR As Long
Dim j As Integer
Dim MyArr
   MyArr = Array(1, 6, 10)
With Worksheets("Заполнить")
   .Columns("D").ClearContents
   .Cells(3, 4) = "Код"
   For j = 0 To UBound(MyArr)
    iLastRow = Cells(Rows.Count, MyArr(j)).End(xlUp).Row
       iLR = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
       Range(Cells(2, MyArr(j)), Cells(iLastRow, MyArr(j))).Copy .Cells(iLR, 4)
   Next
End With
End Sub
[/vba]
Автор - Kuzmich
Дата добавления - 02.12.2017 в 13:57
Serg_naum Дата: Суббота, 02.12.2017, 17:10 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Kuzmich, спасибо, но есть 1 ошибка.
Может не ошибка, может быть я неправильно описал.
Макрос подтягивает сначала в D3 на листе "Заполнить" ячейку B1, а нужны только значения.
Но есть еще один момент, который я не описал: как сделать так, чтобы пропуски он не переносил?
Чтобы только значения переносились, а если пропуск, то вставлялось следующее значение.
В примере отобразил в столбце G.
К сообщению приложен файл: 0846402.xls (40.5 Kb)
 
Ответить
СообщениеKuzmich, спасибо, но есть 1 ошибка.
Может не ошибка, может быть я неправильно описал.
Макрос подтягивает сначала в D3 на листе "Заполнить" ячейку B1, а нужны только значения.
Но есть еще один момент, который я не описал: как сделать так, чтобы пропуски он не переносил?
Чтобы только значения переносились, а если пропуск, то вставлялось следующее значение.
В примере отобразил в столбце G.
Автор - Serg_naum
Дата добавления - 02.12.2017 в 17:10
Kuzmich Дата: Суббота, 02.12.2017, 17:29 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация: 156 ±
Замечаний: 0% ±

Excel 2003
[vba]
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim j As Integer
Dim MyArr
   MyArr = Array(1, 6, 10)
With Worksheets("Заполнить")
   .Columns("D").ClearContents
   .Cells(3, 4) = "Код"
   For j = 0 To UBound(MyArr)
    iLastRow = Cells(Rows.Count, MyArr(j)).End(xlUp).Row
       iLR = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
       Range(Cells(2, MyArr(j)), Cells(iLastRow, MyArr(j))).Copy .Cells(iLR, 4)
   Next
       iLR = .Cells(.Rows.Count, 4).End(xlUp).Row
   For i = iLR To 4 Step -1
     If IsEmpty(.Cells(i, 4)) Then
       .Cells(i, 4).Delete
     End If
   Next
   .Cells(3, 4).Delete
End With
End Sub
[/vba]
 
Ответить
Сообщение[vba]
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim j As Integer
Dim MyArr
   MyArr = Array(1, 6, 10)
With Worksheets("Заполнить")
   .Columns("D").ClearContents
   .Cells(3, 4) = "Код"
   For j = 0 To UBound(MyArr)
    iLastRow = Cells(Rows.Count, MyArr(j)).End(xlUp).Row
       iLR = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
       Range(Cells(2, MyArr(j)), Cells(iLastRow, MyArr(j))).Copy .Cells(iLR, 4)
   Next
       iLR = .Cells(.Rows.Count, 4).End(xlUp).Row
   For i = iLR To 4 Step -1
     If IsEmpty(.Cells(i, 4)) Then
       .Cells(i, 4).Delete
     End If
   Next
   .Cells(3, 4).Delete
End With
End Sub
[/vba]
Автор - Kuzmich
Дата добавления - 02.12.2017 в 17:29
Serg_naum Дата: Суббота, 02.12.2017, 18:08 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Kuzmich, спасибо, сработало.
 
Ответить
СообщениеKuzmich, спасибо, сработало.
Автор - Serg_naum
Дата добавления - 02.12.2017 в 18:08
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копировать значения из 3 столбцов в 1 по порядку с пропускам (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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