Добрый день! тема уже обсуждалась на форуме в ней был предложен следующий макрос для ее решения:

Sub Copy_Only_FreeCells()
Dim rCopyRange As Range, rPasteRange As Range, rCell As Range
On Error Resume Next: Application.DisplayAlerts = False
Set rCopyRange = Application.InputBox("Выберите диапзаон для копирования", "Выбор данных", Type:=
If rCopyRange Is Nothing Then MsgBox "Не выбран диапазон", vbCritical, "Ошибка": Exit Sub
Set rPasteRange = Application.InputBox("Выберите диапзаон для вставки", "Выбор данных", Type:=
If rPasteRange Is Nothing Then MsgBox "Не выбран диапазон", vbCritical, "Ошибка": Exit Sub
On Error GoTo 0: Application.DisplayAlerts = True

rCopyRange.Parent.Activate
For Each rCell In rCopyRange
If rCell.Locked = False Then rCell.Copy rPasteRange.Parent.Range(rCell.Address)
Next rCell

End Sub

Применив на своем примере результата не получил. Подскажите пожалуйста в чем ошибка или как его можно модернизовать для моего примера. Версия Excel - 2010
ссылка на тему ранее обсуждавшуюся http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=8&TID=13499