Макрос excel перенос столбца - Word и Excel - помощь в работе с программами

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

07.05.2014, 15:47. Показов 12376. Ответов 19

Собсетвено есть данные в столбцах А , В , С , D.
Нужно сделать так что бы столбец С поменялся местами со столбцом В вместе со всеми данными? с помошью макроса VBA
Буду благодарен любым вашим мыслям!

Programming Эксперт 94731 / 64177 / 26122 Регистрация: 12.04.2006 Сообщений: 116,782	07.05.2014, 15:47
19

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

07.05.2014, 15:56

Banzayl2w, запишите макрорекордером действия: выделить ст. С, Ctrl+X, выделить ст. В, Вставить — Вставить вырезанные ячейки.

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

07.05.2014, 16:07

[ТС]

надо бы довести «до ума» через получившиеся макросы вручную в VB

Добавлено через 2 минуты
просто как вы говорите делать данные куда вставляешь теряются а надо что бы они сместились оставаясь в табличке

OLEGOFF

1062 / 506 / 137

Регистрация: 27.02.2013

Сообщений: 1,451

07.05.2014, 16:28

Попробуй так

Visual Basic

Sub замена()
 
    Columns("C:C").Select
    Selection.Cut
    Columns("T:T").Select
    ActiveSheet.Paste
    Columns("B:B").Select
    Selection.Cut
    Columns("C:C").Select
    ActiveSheet.Paste
    Columns("T:T").Select
    Selection.Cut
    Columns("B:B").Select
    ActiveSheet.Paste
End Sub

Через любой свободный столбец

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

07.05.2014, 16:35

[ТС]

нет все столбцы забиты данными нужно данные столбца D поменять с данными столбца А, просто перенести местами

OLEGOFF

1062 / 506 / 137

Регистрация: 27.02.2013

Сообщений: 1,451

07.05.2014, 17:14

Так что-ли?

Visual Basic

Sub UpToDown()
Dim A, B
    A = [C:C]
    B = [B:B]
    
   [C:C] = B
   [B:B] = A
End Sub

Казанский

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

07.05.2014, 17:49

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

как вы говорите делать данные куда вставляешь теряются

Неправда! Вот записанный макрос:

Visual Basic

Sub Макрос2()
'
' Макрос2 Макрос
'
 
'
    Columns("C:C").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
End Sub

Для решения учебного задания этого достаточно. Если убрать лишнее, то так:

Visual Basic

Sub Макрос2()
    Columns("C").Cut
    Columns("B").Insert
End Sub

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

08.05.2014, 11:44

[ТС]

Не работает макрос не переносит (

6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

08.05.2014, 11:49

Не буду спорить — но счёт 2:1 не в Вашу пользу — у меня и Алексея работает

По макросу OLEGOFF аналогично 2:1

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

08.05.2014, 12:21

[ТС]

файл ниже вот нужно поменять столбец A cо столбцом D местами, и код не хочет работать)

6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

08.05.2014, 12:53

И где тот код, который не хочет работать?

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

08.05.2014, 12:59

[ТС]

ниже

6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

08.05.2014, 13:00

Вообще понятно — уж сколько говорено, что объединение ячеек — эло! Повторю ещё раз.

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

08.05.2014, 13:04

[ТС]

тоесть никак не решить эту задачу? с переносом данных из одного столбца в другой?

Hugo121

6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

08.05.2014, 13:04

Visual Basic

Sub Макрос333()
    Columns(1).Cut
    Columns(4).Insert
    Columns(4).Cut
    Columns(1).Insert
End Sub

Только сперва уберите объединение в A!

Казанский

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

08.05.2014, 13:06

Сообщение было отмечено Banzayl2w как решение

Решение

С автоматическим снятием объединения ячеек в задействованных столбцах

Visual Basic

Sub Макрос1()
Dim c As Range
For Each c In Intersect(Range("A:A,D:D"), ActiveSheet.UsedRange)
  If c.MergeCells Then
    If c.MergeArea.Columns.Count > 1 Then c.UnMerge
  End If
Next
  
Columns("D").Cut
Columns("A").Insert
Columns("B").Cut
Columns("E").Insert
End Sub

6875 / 2807 / 533

Регистрация: 19.10.2012

Сообщений: 8,562

08.05.2014, 13:07

Сообщение было отмечено Banzayl2w как решение

Решение

И чего не все варианты пробовали? Вариант через массив работает «из коробки», только диапазоны изменить, и объединения не мешают.
И это будет именно перенос данных в чистом виде!

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

08.05.2014, 13:14

[ТС]

Огромное спасибо!

1062 / 506 / 137

Регистрация: 27.02.2013

Сообщений: 1,451

08.05.2014, 13:24

У меня все работает…?

1 / 1 / 0

Регистрация: 14.04.2014

Сообщений: 40

08.05.2014, 13:26

[ТС]

Да, все работает!

IT_Exp

Эксперт

87844 / 49110 / 22898

Регистрация: 17.06.2006

Сообщений: 92,604

08.05.2014, 13:26

Помогаю со студенческими работами здесь

Макрос VBA
Добрый день!Помогите с задачей.

Создать макрос , доступный во всей рабочей книге, в
процессе…

Макрос.VBA
Создать Mакрос в Word, так чтобы он находил в тексте буквосочетание и выделял его цветом, а потом…

Макрос VBA
Помогите написать макрос или подскажите как должен выглядеть. есть база данных макрос ищет по…

Перемещение с переименованием файлов в vba
Здравствуйте. Есть задача, найти в целевой папке список имен фото, находящийся в столбце 1 Excel, и…

Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:

Источник

Вставка диапазона со сдвигом ячеек вправо или вниз методом Insert объекта Range. Вставка и перемещение строк и столбцов из кода VBA Excel. Примеры.

Range.Insert – это метод, который вставляет диапазон пустых ячеек (в том числе одну ячейку) на рабочий лист Excel в указанное место, сдвигая существующие в этом месте ячейки вправо или вниз. Если в буфере обмена содержится объект Range, то вставлен будет он со своими значениями и форматами.

Синтаксис

Expression.Insert(Shift, CopyOrigin)

Expression – выражение (переменная), возвращающее объект Range.

Параметры

Параметр	Описание	Значения
Shift	Необязательный параметр. Определяет направление сдвига ячеек. Если параметр Shift опущен, направление выбирается в зависимости от формы* диапазона.	xlShiftDown (-4121) – ячейки сдвигаются вниз; xlShiftToRight (-4161) – ячейки сдвигаются вправо.
CopyOrigin	Необязательный параметр. Определяет: из каких ячеек копировать формат. По умолчанию формат копируется из ячеек сверху или слева.	xlFormatFromLeftOrAbove (0) – формат копируется из ячеек сверху или слева; xlFormatFromRightOrBelow (1) – формат копируется из ячеек снизу или справа.

* Если диапазон горизонтальный или квадратный (количество строк меньше или равно количеству столбцов), ячейки сдвигаются вниз. Если диапазон вертикальный (количество строк больше количества столбцов), ячейки сдвигаются вправо.

Примеры

Простая вставка диапазона

Вставка диапазона ячеек в диапазон «F5:K9» со сдвигом исходных ячеек вправо:

Range(«F5:K9»).Insert Shift:=xlShiftToRight

Если бы параметр Shift не был указан, сдвиг ячеек, по умолчанию, произошел бы вниз, так как диапазон горизонтальный.

Вставка вырезанного диапазона

Вставка диапазона, вырезанного в буфер обмена методом Range.Cut, из буфера обмена со сдвигом ячеек по умолчанию:

Range(«A1:B6»).Cut

Range(«D2»).Insert

Обратите внимание, что при использовании метода Range.Cut, точка вставки (в примере: Range("D2")) не может находится внутри вырезанного диапазона, а также в строке или столбце левой верхней ячейки вырезанного диапазона вне вырезанного диапазона (в примере: строка 1 и столбец «A»).

Вставка скопированного диапазона

Вставка диапазона, скопированного в буфер обмена методом Range.Copy, из буфера обмена со сдвигом ячеек по умолчанию:

Range(«B2:D10»).Copy

Range(«F2»).Insert

Обратите внимание, что при использовании метода Range.Copy, точка вставки (в примере: Range("F2")) не может находится внутри скопированного диапазона, но в строке или столбце левой верхней ячейки скопированного диапазона вне скопированного диапазона находится может.

Вставка и перемещение строк

Вставка одной строки на место пятой строки со сдвигом исходной строки вниз:

Вставка четырех строк на место пятой-восьмой строк со сдвигом исходных строк вниз:

Вставка строк с использованием переменных, указывающих над какой строкой осуществить вставку и количество вставляемых строк:

Sub Primer1()

Dim n As Long, k As Long, s As String

‘Номер строки, над которой необходимо вставить строки

n = 8

‘Количесто вставляемых строк

k = 4

‘Указываем адрес диапазона строк

s = n & «:» & (n + k — 1)

‘Вставляем строки

Rows(s).Insert

End Sub

‘или то же самое с помощью цикла

Sub Primer2()

Dim n As Long, k As Long, i As Long

n = 8

k = 4

For i = 1 To k

Rows(n).Insert

End Sub

Перемещение второй строки на место шестой строки:

Rows(2).Cut

Rows(6).Insert

Вторая строка окажется на месте пятой строки, так как третья строка заместит вырезанную вторую строку, четвертая встанет на место третьей и т.д.

Перемещение шестой строки на место второй строки:

Rows(6).Cut

Rows(2).Insert

В этом случае шестая строка окажется на месте второй строки.

Вставка и перемещение столбцов

Вставка одного столбца на место четвертого столбца со сдвигом исходного столбца вправо:

Вставка трех столбцов на место четвертого-шестого столбцов со сдвигом исходных столбцов вправо:

Перемещение третьего столбца на место седьмого столбца:

Columns(3).Cut

Columns(7).Insert

Третий столбец окажется на месте шестого столбца, так как четвертый столбец заместит вырезанный третий столбец, пятый встанет на место четвертого и т.д.

Перемещение седьмого столбца на место третьего столбца:

Columns(7).Cut

Columns(3).Insert

В этом случае седьмой столбец окажется на месте третьего столбца.

Источник

Перемещение столбцов без копирования

Roman777

Дата: Четверг, 17.09.2015, 15:48 |
Сообщение № 1

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация:
127
±

Замечаний:
0% ±

Excel 2007, Excel 2013

Добрый день!
Подскажите, пожалуйста, возможно ли переместить столбцы без использования промежуточного копирования данных?
Поясню: необходимо, чтоб столбцы 2й и 4й поменялись местами (данные из столбца(2) стали во четвёртый столбец, а данные из столбца(4) во второй).

Много чего не знаю!!!!

Ответить

Pelena

Дата: Четверг, 17.09.2015, 16:28 |
Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 18797

Репутация:
4284
±

Замечаний:
±

Excel 2016 & Mac Excel

Здравствуйте.
Макрорекодер подсказывает так
[vba]

Код

Sub Макрос1()
‘
‘ Макрос1 Макрос
‘

‘
     Columns(«B:B»).Cut
     Columns(«D:D»).Insert Shift:=xlToRight
     Columns(«D:D»).Cut
     Columns(«B:B»).Insert Shift:=xlToRight
End Sub

[/vba]

«Черт возьми, Холмс! Но как??!!»
Ю-money 41001765434816

Ответить

Roman777

Дата: Четверг, 17.09.2015, 16:37 |
Сообщение № 3

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация:
127
±

Замечаний:
0% ±

Excel 2007, Excel 2013

Pelena, да, это я уже видел, но мне казалось, что тут происходит промежуточное копирование, а потом удаление столбца… по крайней мере, операция будет крайне долгой для большого кол-ва строк.
Я думал, мб бывает метод типа offset или аналог того, как листы легко можно перемещать внутри книги…

Много чего не знаю!!!!

Ответить

Rioran

Дата: Четверг, 17.09.2015, 17:36 |
Сообщение № 4

Группа: Авторы

Ранг: Ветеран

Сообщений: 903

Репутация:
290
±

Замечаний:
0% ±

Excel 2013

Roman777, здравствуйте.

Я бы сделал так, пример во вложении:

[vba]

Код

Sub RioSwap()
     Dim ArrA, ArrB, RowX&
     RowX = ActiveSheet.UsedRange.Rows.Count
     ArrA = Range(«B1:B» & RowX)
     ArrB = Range(«D1:D» & RowX)
     Range(«B1:B» & RowX) = ArrB
     Range(«D1:D» & RowX) = ArrA
End Sub

[/vba]

К сообщению приложен файл:

RioSwap.xlsb
(14.4 Kb)

Роман, Москва, voronov_rv@mail.ru
Яндекс-Деньги: 41001312674279

Ответить

Roman777

Дата: Четверг, 17.09.2015, 17:55 |
Сообщение № 5

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация:
127
±

Замечаний:
0% ±

Excel 2007, Excel 2013

Rioran, Я правильно понял, что тут мы просто записываем в память данные а потом из памяти кидаем в соответствующий столбик?
странно что ActiveSheet.UsedRange.Rows.Count выдаёт мне значение 10, когда у меня только 9 строк заполнены…
Спасибо большое, оч даже хороший Вариант, а я циклами делал…

Много чего не знаю!!!!

Ответить

Roman777

Дата: Четверг, 17.09.2015, 17:59 |
Сообщение № 6

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация:
127
±

Замечаний:
0% ±

Excel 2007, Excel 2013

Rioran, Подскажите вот ещё что, в Вашем коде, ArrA и ArrB объявлены как Variant, такой метод работает только при таком типе для данных переменных?

Много чего не знаю!!!!

Ответить

Rioran

Дата: Четверг, 17.09.2015, 18:15 |
Сообщение № 7

Группа: Авторы

Ранг: Ветеран

Сообщений: 903

Репутация:
290
±

Замечаний:
0% ±

Excel 2013

мы просто записываем в память данные а потом из памяти кидаем в соответствующий столбик

Совершенно верно.

ActiveSheet.UsedRange.Rows.Count выдаёт мне значение 10

Значит, Вы как-то раз задействовали 10-ю строку, это нормально. Даже если Вы с 10-й строки потом значение стёрли.

ArrA и ArrB объявлены как Variant

Мой метод работает как минимум при этом типе переменной. В момент присвоения значения эти переменные превращаются в двумерные массивы. Конечно, переменные можно объявлять как массивы, но это не всегда удобно.

Роман, Москва, voronov_rv@mail.ru
Яндекс-Деньги: 41001312674279

Сообщение отредактировал Rioran — Четверг, 17.09.2015, 18:16

Ответить

Roman777

Дата: Четверг, 17.09.2015, 21:14 |
Сообщение № 8

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация:
127
±

Замечаний:
0% ±

Excel 2007, Excel 2013

Rioran, ещё раз благодарю за столь подробные разъяснения)))

Много чего не знаю!!!!

Ответить

Источник

irina_iv

Пользователь

Сообщений: 21
Регистрация: 11.12.2018

29.12.2018 10:02:44

Уважаемые программисты, можно ли к Вам обратиться помочь доработать код?
С листа «details» копируем 2 столбца, потом еще 10, но помещаем их в новый лист через 1 (начиная с 3-го столбца-2 мы уже скопировали). Файл прилагаю.

Код

Private Sub Worksheet_Activate()
Dim i As Long, j As Long, lrow As Long
Dim UserRange As Range
Dim iCells As Range
lrow = UserRange.Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("details").Range("B2").CurrentRegion
Set UserRange = Sheets("details").Union(.Columns("B"), .Columns("C"), .Range("R2:AB2"))
Union(.Columns("B"), .Columns("C")).Copy Sheets("Лист1").Range("B1")
'Range("R2:AB2").Copy Cells(RowsCount, "D").End(xlUp).Offset(2)
'значения вставляются каждый раз в следующую строку
End With

'Range("R2:AB2" & lrow).Copy Sheets("Лист1").Range("D2")
For Each iCells In Sheets("details").Range("R2" & lrow & ":AB2" & lrow)
If Worksheets("details").Cells(iCells, "R2").Value > 0 Then
For W = 3 To lrow
If IsEmpty(Cells(W, 1)) Then
For j = 1 To 10 'так как нужно скопировать с R2 по AB2 -10- столбцов
Do
Cells(W, j) = Worksheets("details").Cells(iCells, j)
j = 2 * j + 1
iCells = iCells + 1
Loop Until Columns(j).Find(What:="*") Is Nothing Or j = Columns.Count
     '.PasteSpecial xlPasteAll
     .PasteSpecial xlPasteColumnWidths ' ширина столбца'
     .PasteSpecial xlPasteValues ' значения'
     .PasteSpecial xlPasteFormats ' форматы'
 
Next j
Exit For
End If
Next W
End If
Next iCells
'End With
Application.CutCopyMode = False
End Sub

На листе2 показано, как это должно выглядеть.

Прикрепленные файлы

avan_3.rar (166.33 КБ)

Изменено: irina_iv — 29.12.2018 10:05:27

Kuzmich Пользователь Сообщений: 7998 Регистрация: 21.12.2012	У меня ваш архив не открылся.

irina_iv Пользователь Сообщений: 21 Регистрация: 11.12.2018	Вот так примерно… Изменено: irina_iv — 29.12.2018 14:46:45

Kuzmich

Пользователь

Сообщений: 7998
Регистрация: 21.12.2012

29.12.2018 15:01:52

Цитата
Private Sub Worksheet_Activate()

При активации какого листа срабатывает макрос?

Цитата
Sheets(«Лист1»).Range(«B1»)

В книге нет Листа1

RAN Пользователь Сообщений: 7091 Регистрация: 21.12.2012	Удалить из каждой таблицы по 1500 строк — такая проблема? Тогда, глядишь, и для макросов место найдется.

Dima S Пользователь Сообщений: 2063 Регистрация: 01.01.1970	у кого то из форумчан была очень актуальная для вашего файла подпись: «если автоматизировать бардак, то получится автоматизированный бардак». я думаю во многом из-за этого так много желающих разбираться в вашем файле.

irina_iv

Пользователь

Сообщений: 21
Регистрация: 11.12.2018

Ну, Вы, конечно, шутники…Я и вправду удалила (случайно) лист1, хотя он там нужен. Но «бардаком» я бы не стала это называть: во-первых, я новичок, во-вторых, это таблицы, а разве можно таблицы назвать бардаком?..
Неравнодушным людям буду очень благодарна, ибо доделать макрос сама не могу пока. Копирование с листа «details» должно выглядеть как лист «pre».
P.s. Всех с прошедшими праздниками!

Прикрепленные файлы

avans.rar (141.28 КБ)

Anchoret Пользователь Сообщений: 1061 Регистрация: 01.01.1970 Anchoret	irina_iv, Не равнодушным людям трудно понять в Вашем файле чего Вы собственно хотите. Можете описать хотелку своими словами без разгадывания шарад в неработающем коде вашего файла?

Nordheim Пользователь Сообщений: 3154 Регистрация: 18.04.2017	А можете сделать файл на одном листе таблица 10х10 (рога, копыта), на другом , то как она должна выглядеть после копирования. В Вашем макросе нет желания разбирать ошибки. «Все гениальное просто, а все простое гениально!!!»

irina_iv

Пользователь

Сообщений: 21
Регистрация: 11.12.2018

Конечно. Два столбца «ФИО агента» и «Адрес» переносятся с листа «details» на «Лист1» и находятся рядом, остальные столбцы «аванс», «зп1-зп10» — переносятся на лист «Лист1» через один столбец (чтобы между можно было вписывать даты). То есть все должно выглядеть как на листе ‘pre’. Было бы замечательно, если можно было бы сделать форматирование как на листе «pre» на листе1. (цвета, толщина, центрирование и т.д.). Конечно, не мучайтесь . Я на этот код потратила недели 2, и он еще не работает…
P.s. Спасибо, люди добрые,-у меня даже надежда появилась!
P.p.s. В принципе, можно скопировать на лист «pre’, только чтобы форматирование этой таблицы сохранилось.

Изменено: irina_iv — 09.01.2019 15:04:42

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

Немного не понятно, зачем копировать столбцы, копируйте весь лист, затем вставьте столбцы где вам нужно, а лишнее удалите. Если таблица имеет одинаковую структуру всегда, то можно макрорекодером записать макрос, а после лишнее удалить.

Изменено: Nordheim — 09.01.2019 15:11:19

«Все гениальное просто, а все простое гениально!!!»

irina_iv Пользователь Сообщений: 21 Регистрация: 11.12.2018	Ну, можно, конечно, и так сделать. А как у меня будут тогда добавляться новые значения? Каждый раз заново копировать лист? Только я думала, что так будет интереснее. P.s. С макрорекордером обращаться не умею…

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#13

09.01.2019 15:34:01

Цитата
irina_iv написал: А как у меня будут тогда добавляться новые значения?

А как они у Вас сейчас добавляются, или будут добавляться после копирования?

Цитата
irina_iv написал: P.s. С макрорекордером обращаться не умею…

Т.е. макросы писать можете, а макрорекодером пользоваться не умеете? Как это так?

«Все гениальное просто, а все простое гениально!!!»

Nordheim Пользователь Сообщений: 3154 Регистрация: 18.04.2017	Наверно копирование листа вам не подойдет, если у Вас уже будут заполнены доп столбцы «Все гениальное просто, а все простое гениально!!!»

irina_iv Пользователь Сообщений: 21 Регистрация: 11.12.2018	Да, здесь бы лучше циклом или еще как-то, как быстро и точно… А мой точно не хотите посмотреть? Может, быстрее будет?..

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#16

09.01.2019 15:46:03

Цитата
irina_iv написал: А мой точно не хотите посмотреть?

Нет. Но на вскидку, это к чему относится?

Код
.PasteSpecial xlPasteColumnWidths ' ширина столбца' .PasteSpecial xlPasteValues ' значения' .PasteSpecial xlPasteFormats

«Все гениальное просто, а все простое гениально!!!»

Anchoret

Пользователь

Сообщений: 1061
Регистрация: 01.01.1970

Anchoret

#17

09.01.2019 16:19:59

irina_iv, пробуйте (не тестировал, т.к. не хватило времени — на работе). Предполагается, что лист с индесом 1 — лист с исходными данными, с индексом 3 — место выгрузки:

Код

Sub aaa()
Dim arr(), a&, c%, zz()
zz = Array("Аванс", "Дата", "ЗП")
With Sheets(1)
  a = Application.CountA(Intersect(.UsedRange, .Columns(3)))
  ReDim arr(1 To a, 1 To 25)
  arr(1, 4) = zz(0): arr(1, 5) = zz(1)
  For c = 1 To 10: arr(1, c * 2 - 1 + 5) = zz(2) & "_" & c: arr(1, c * 2 + 5) = zz(1) & "_" & c: Next
  For c = 1 To 3: arr(1, c) = .Cells(2, c).Value: Next
  For a = 2 To a
    For c = 2 To 3: arr(a, c) = .Cells(a + 1, c).Value: Next
    arr(a, 4) = .Cells(a + 1, 18): arr(a, 1) = a - 1
    For c = 1 To 10: arr(a, c * 2 - 1 + 5) = .Cells(a + 1, c + 18): Next
  Next
End With
With Sheets(4)
  .UsedRange.Clear: .UsedRange.Clear
  With .[a1].Resize(UBound(arr, 1), UBound(arr, 2))
    .Borders.LineStyle = xlContinuous: .Value = arr
  End With
  .Rows(1).AutoFilter: .UsedRange.EntireColumn.AutoFit
End With
End Sub

Изменено: Anchoret — 10.01.2019 10:33:35

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#18

09.01.2019 16:23:34

Вариант для файла из сообщения №3

Код

Sub test()
'   -----------------------------------------------
    Dim i&, j&, sht As Worksheet, sh As Worksheet, lrow&
'   -----------------------------------------------
    Application.ScreenUpdating = False
    Set sht = ThisWorkbook.Worksheets("как должно быть")
    Set sh = ThisWorkbook.Worksheets("details")
    With sh
        lrow = .UsedRange.Rows.Count
        .Range("b1:c" & lrow).Copy
        sht.[b1].PasteSpecial xlPasteValues
        j = 6
        For i = 19 To 28
           .Range(.Cells(1, i), .Cells(lrow, i)).Copy
           sht.Cells(1, j).PasteSpecial xlPasteValues
           j = j + 2
        Next i
    End With
    Application.ScreenUpdating = True
    Set sh = Nothing: Set sht = Nothing
End Sub

«Все гениальное просто, а все простое гениально!!!»

irina_iv Пользователь Сообщений: 21 Регистрация: 11.12.2018	Anchoret, Nordheim, спасибо большое, очень тронута . Единственное, что пишут: «can`t execute code in break mode». Nordheim, «как должно быть» — это название листа, на который копируют?

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#20

10.01.2019 10:32:04

Цитата
irina_iv написал: Nordheim, «как должно быть» — это название листа, на который копируют?

Совершенно верно.

«Все гениальное просто, а все простое гениально!!!»

Anchoret

Пользователь

Сообщений: 1061
Регистрация: 01.01.1970

Anchoret

irina_iv, да, там была ошибка и не одна. Изменил код выше. Лист выгрузки теперь имеет индекс 4. Соответственно все индексы листов можно переименовать названиями реальных листов.

П.С.: Есть один нюанс — если даты планировалось вводить вручную и вне зависимости от времени запуска этого макроса, то грусть-печаль. Макрос затирает при выгрузке все данные под выгружаемой таблицей.

irina_iv Пользователь Сообщений: 21 Регистрация: 11.12.2018	Да, Anchoret. данные планировалось по датам вводить вручную. То есть просто скопировать с интервалом столбцы (кроме первых двух)… Не бросайте меня, Вы и Nordheim — моя последняя надежда …

Anchoret

Пользователь

Сообщений: 1061
Регистрация: 01.01.1970

Anchoret

#23

10.01.2019 11:37:36

irina_iv, по сути код идентичный коду от Nordheim, только не очень читабельный :

Код

Sub bbb()
Dim a&, c%, zz(), sh1 As Worksheet, sh2 As Worksheet
zz = Array("Аванс", "Дата", "ЗП")
Set sh1 = Sheets(1): Set sh2 = Sheets(4)
  If sh2.AutoFilterMode = True Then sh2.ShowAllData
  a = Application.CountA(Intersect(sh1.UsedRange, sh1.Columns(3)))
  sh2.Range("D1:D" & a).Value = sh1.Range("R2:R" & a + 1).Value
  sh2.Range("A1:C" & a).Value = sh1.Range("A2:C" & a + 1).Value
  For c = 1 To 10: sh2.Cells(1, c * 2 - 1 + 5) = zz(2) & "_" & c: sh2.Cells(1, c * 2 + 5) = zz(1) & "_" & c: Next
  sh2.Cells(1, 4) = zz(0): sh2.Cells(1, 5) = zz(1)
  For c = 1 To 10
    sh2.Range(sh2.Cells(2, c * 2 - 1 + 5), sh2.Cells(a, c * 2 - 1 + 5)).Value = sh1.Range(sh1.Cells(3, c + 18), sh1.Cells(a + 1, c + 18)).Value
  Next
  sh2.[a1].Resize(a, 25).Borders.LineStyle = xlContinuous
  sh2.UsedRange.EntireColumn.AutoFit
End Sub

Изменено: Anchoret — 10.01.2019 12:08:28

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#24

10.01.2019 12:18:05

Цитата
Anchoret написал: не очень читабельный

Возможно так будет более «читабелно»

Скрытый текст

«Все гениальное просто, а все простое гениально!!!»

Anchoret Пользователь Сообщений: 1061 Регистрация: 01.01.1970 Anchoret	Nordheim, точно) irina_iv, есть у меня стойкое подозрение, что макросы здесь и не нужны. Т.е. достаточно формул типа «=A2=такой-то лист!A3» и т.д..

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

Есть подозрение что irina_iv, на примере макросов по этой задаче, продолжит изучение VBA, что то почерпнет, увидит ошибки допущенные в собственном коде, и попытается в дальнейшем, продолжить автоматизацию работы в Excel.

«Все гениальное просто, а все простое гениально!!!»

irina_iv

Пользователь

Сообщений: 21
Регистрация: 11.12.2018

Можно Вас, Anchoret, Nordheim еще немного помучать?
Anchoret, оригинально протаскивать, но замучаешься .
Мне нужно чтобы только копировались:
«ФИО агента», «адрес» (из начала таблицы) и кусочек, начиная с [«аванс», «зп1»-«зп10»]. В квадратных скобках то, что должно копироваться через столбец на новый лист. Столбцы дата 1-дата 10 я прописала вручную, но так даже лучше.
Насколько я поняла, копирование должно быть на лист1, но у меня произошло также копирование на лист «pre», причем в принципе правильно, но 2 лишних столбца: столбец 2 с нумерацией (у меня уже был столбец с нумерацией) и столбец 5 (пустой). И изменился формат таблицы. Не очень понятно…

irina_iv Пользователь Сообщений: 21 Регистрация: 11.12.2018

Nordheim Пользователь Сообщений: 3154 Регистрация: 18.04.2017	Честно говоря, какая то ерунда получается, наверно следует таблицы , как то более грамотно составить, или я чего то не понимаю. «Все гениальное просто, а все простое гениально!!!»

Anchoret Пользователь Сообщений: 1061 Регистрация: 01.01.1970 Anchoret	#30 10.01.2019 14:11:23 irina_iv, рыба закончилась, настала пора удочки: — Выберите любой из вариантов кода, — введите в нужном месте название листа-получателя — зайдите в редактор VBE — пошагово (F8) выполните макрос

Источник

В этой статье я представляю код VBA для переноса столбцов в строки и вставки новых строк для заполнения данных, как показано на скриншоте ниже. Если вас интересует эта операция, перейдите по ссылке ниже для получения дополнительных сведений.

Транспонировать и вставлять строки с помощью VBA

Транспонировать и вставлять строки с помощью VBA

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

1. Нажмите Alt + F11 ключи для открытия Microsoft Visual Basic для приложений окно.

2. Нажмите Вставить > Модулии вставьте под кодом VBA в окно модуля. Смотрите скриншот:

VBA: транспонировать и вставлять строки.

 Sub TransposeInsertRows()
'UpdatebyExtendoffice20161125
    Dim xRg As Range
    Dim i As Long, j As Long, k As Long
    Dim x As Long, y As Long
    Set xRg = Application.InputBox _
    (Prompt:="Range Selection...", _
    Title:="Kutools For Excel", Type:=8)
    Application.ScreenUpdating = False
    x = xRg(1, 1).Column + 2
    y = xRg(1, xRg.Columns.Count).Column
    For i = xRg(xRg.Rows.Count, 1).Row To xRg(1, 1).Row Step -1
        If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
            k = Cells(i, x - 2).End(xlToRight).Column
            If k > y Then k = y
            For j = k To x + 1 Step -1
                Cells(i + 1, 1).EntireRow.Insert
                With Cells(i + 1, x - 2)
                    .Value = .Offset(-1, 0)
                    .Offset(0, 1) = .Offset(-1, 1)
                    .Offset(0, 2) = Cells(i, j)
                End With
                Cells(i, j).ClearContents
            Next j
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

3. Нажмите F5 нажмите клавишу, чтобы запустить код, а затем выберите диапазон данных, который вы хотите транспонировать, и вставьте строки в всплывающее диалоговое окно. Смотрите скриншот:

4. Нажмите OK. И выбранный диапазон был преобразован, как показано на скриншоте ниже.

Внимание: перед запуском кода лучше сохранить копию исходных данных.

Наконечник.Если вы хотите быстро преобразовать перекрестную таблицу в таблицу списка или наоборот, попробуйте использовать Kutools for ExcelАвтора Перенести размеры таблицы как показано на следующем снимке экрана. Полная функция без ограничений в 30 дней, пожалуйста, скачайте и получите бесплатную пробную версию сейчас.

Лучшие инструменты для работы в офисе

Kutools for Excel Решит большинство ваших проблем и повысит вашу производительность на 80%

Снова использовать: Быстро вставить сложные формулы, диаграммы и все, что вы использовали раньше; Зашифровать ячейки с паролем; Создать список рассылки и отправлять электронные письма …
Бар Супер Формулы (легко редактировать несколько строк текста и формул); Макет для чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон…
Объединить ячейки / строки / столбцы без потери данных; Разделить содержимое ячеек; Объединить повторяющиеся строки / столбцы… Предотвращение дублирования ячеек; Сравнить диапазоны…
Выберите Дубликат или Уникальный Ряды; Выбрать пустые строки (все ячейки пустые); Супер находка и нечеткая находка во многих рабочих тетрадях; Случайный выбор …
Точная копия Несколько ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое …
Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов по страницам; Преобразование содержимого ячеек в комментарии…
Суперфильтр (сохранять и применять схемы фильтров к другим листам); Расширенная сортировка по месяцам / неделям / дням, периодичности и др .; Специальный фильтр жирным, курсивом …
Комбинируйте книги и рабочие листы; Объединить таблицы на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF…
Более 300 мощных функций. Поддерживает Office/Excel 2007-2021 и 365. Поддерживает все языки. Простое развертывание на вашем предприятии или в организации. Полнофункциональная 30-дневная бесплатная пробная версия. 60-дневная гарантия возврата денег.

Вкладка Office: интерфейс с вкладками в Office и упрощение работы

Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!

Комментарии (8)

Оценок пока нет. Оцените первым!

Источник