Снятие объединения ячеек в файле Excel для загрузки компаний в Битрикс24
В чем здесь проблема?
А в том, что, для удобства, менеджер объединил ячейки по вертикали:
Для работы менеджера это может быть и удобно, а для работы с файлом, как с базой данных, совсем не удобно.
Чтобы продолжить работать с файлом, выделить из него компании и контакты для загрузки в Битрикс24, необходимо привести файл вот к такому виду:
Когда в таблице несколько десятков строк, можно вручную снять объединение с ячеек, а потом заполнить пустые ячейки (например, по CTRL+D).
Но что делать, если таких строк несколько тысяч и в каждой строке есть объединения по нескольким колонкам?
Нашел на просторах интернета отличное решение, которое на одном из проектов по Битрикс24 сэкономило нам много человеко-часов. Спасибо автору )
Собственно, все сводится к макросу, который решает эту задачу (текст макроса в конце поста).Установка макроса
Сначала нужно включить в Excel-е возможность работать с макросами. В моем случае это MS Excel 2013. Делается так:
1. Открыть вкладку «Файл»
2. Выбрать пункт «Параметры»
3. Выбрать пункт «Настроить ленту»
4. В разделе «Настройка ленты» справа в списке «Основные вкладки» установить флаг «Разработчик», нажать «ОК»
2. Правой кнопкой по «ЭтаКнига» – Insert – Module
3. Откроется пустое окно редактирования модуля, куда нужно вставить код макроса. Выглядит примерно так:
4. После этого нужно закрыть окно модуля и окно редактора VisualBasic. Все готово, можно пользоваться
Использование макроса
1. Необходимо выделить всю область таблицы, после чего на вкладке «РАЗРАБОТЧИК» нажать кнопку «Макросы» (ALT-F8).
Выбираем наш макрос с именем «UnMerge_andFill» и жмем «Выполнить»
2. Есть две опции работы маркоса. В случае с простым текстом, в ячейках, нажимаем «НЕТ» и получаем решение задачи:
Всем удачи! )
Текст макроса
Sub UnMerge_and_Fill()
'---------------------------------------------------------------------------------------
' Procedure : UnMerge_and_Fill
' Topic_HEADER : Снятие объединения ячеек с заполнением
' Topic_URL : http://www.planetaexcel.ru/forum.php?thread_id=3760
' Purpose : Снимает объединение со всех ячеек выделенного диапазона
' и заполняет все разгруппированные ячейки КАЖДОЙ бывшей группы
' либо ссылками на значения верхней левой, либо её значениями
'---------------------------------------------------------------------------------------
If Selection.Cells.Count <= 1 Then Exit Sub
Dim rRange As Range, rCell As Range, sValue$, sAddress$, i&
Application.ScreenUpdating = False
Set rRange = Intersect(Selection, ActiveSheet.UsedRange)
Select Case MsgBox("""ДА"" - заполнить ячейки формулами-ссылками на первую ячейку" & vbCrLf & _
"""НЕТ"" - заполнить ячейки значениями из первой ячейки" & vbCrLf & _
"""ОТМЕНА"" не разгруппировывать" _
, vbYesNoCancel + vbQuestion, "Как заполнять ячейки после разгруппировки?")
Case vbYes ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить формулами-ссылками на их первые ячейки
For Each rCell In rRange
If rCell.MergeCells Then
sAddress = rCell.MergeArea.Address: rCell.UnMerge
For i = 2 To Range(sAddress).Cells.Count
With Range(sAddress)
.Cells(i).Formula = "=" & .Cells(1).Address
.Cells(i).Replace What:="$", Replacement:="", LookAt:=xlPart ' сделать ссылки перемещаемыми
.Cells(i).Font.ColorIndex = 5 ' сделать шрифт формул синим (это на любителя, конечно)
End With
Next i
End If
Next rCell
Case vbNo ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить значениями из их первых ячеек
For Each rCell In rRange
If rCell.MergeCells Then
sAddress = rCell.MergeArea.Address: sValue = rCell.Value: rCell.UnMerge
Range(sAddress).Value = rCell.Value
End If
Next
Case vbCancel
If MsgBox("Разгруппировать стандартным способом?", vbYesNo + vbQuestion) = vbYes Then Selection.UnMerge
End Select
rRange.Select
Application.ScreenUpdating = True
End Sub