12 Сентября 2016

Снятие объединения ячеек в файле Excel для загрузки компаний в Битрикс24

Уже много раз сталкивался с ситуацией, когда необходимо из клиентского «человеческого» формата ведения базы клиентов в MS Excel, привести эту базу к формату, пригодному для загрузки в информационные системы.

Вот фрагмент такого формата, который можно получить от клиента:

001.png


В чем здесь проблема?

А в том, что, для удобства, менеджер объединил ячейки по вертикали:

002.png


Для работы менеджера это может быть и удобно, а для работы с файлом, как с базой данных, совсем не удобно.

Чтобы продолжить работать с файлом, выделить из него компании и контакты для загрузки в Битрикс24, необходимо привести файл вот к такому виду:

003.png

Когда в таблице несколько десятков строк, можно вручную снять объединение с ячеек, а потом заполнить пустые ячейки (например, по CTRL+D).

Но что делать, если таких строк несколько тысяч и в каждой строке есть объединения по нескольким колонкам?

Нашел на просторах интернета отличное решение, которое на одном из проектов по Битрикс24 сэкономило нам много человеко-часов. Спасибо автору )

Собственно, все сводится к макросу, который решает эту задачу (текст макроса в конце поста).



Установка макроса


Сначала нужно включить в Excel-е возможность работать с макросами. В моем случае это MS Excel 2013. Делается так:

1. Открыть вкладку «Файл»

2. Выбрать пункт «Параметры»

3. Выбрать пункт «Настроить ленту»

4. В разделе «Настройка ленты» справа в списке «Основные вкладки» установить флаг «Разработчик», нажать «ОК»


После этого в меню появится вкладка «РАЗРАБОТЧИК». Далее нужно сделать следующее:

1. Открыть редактор Visual Basic

004.png

2. Правой кнопкой по «ЭтаКнига» – Insert – Module

005.png

3. Откроется пустое окно редактирования модуля, куда нужно вставить код макроса. Выглядит примерно так:

006.png

4. После этого нужно закрыть окно модуля и окно редактора VisualBasic. Все готово, можно пользоваться



Использование макроса


1. Необходимо выделить всю область таблицы, после чего на вкладке «РАЗРАБОТЧИК» нажать кнопку «Макросы» (ALT-F8).

007.png


Выбираем наш макрос с именем «UnMerge_andFill» и жмем «Выполнить»

2. Есть две опции работы маркоса. В случае с простым текстом, в ячейках, нажимаем «НЕТ» и получаем решение задачи:

008.png

Всем удачи! )



Текст макроса


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
Комментарии0
К этой записи пока нет комментариев. Будьте первым!