Страницы: 1
RSS
Последовательное копирование данных из нескольких столбцов в один
 
            Доброго времени суток! Уважаемые форумчане помогите пожалуйста поправить макрос. Копирует с 13 по 23 столбцы в один на лист 2. Дело в том что в этих столбцах находятся формулы и они же копируются на второй лист в итоге вместо данных получаем "#ССЫЛКА!". Как сделать что бы на второй лист копировались только значения?
Код
Sub Macros1()
Dim i As Long, iLastColumn As Long, iLastRow As Long, lastRow As Long
iLastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   With Sheets("Лист2")
      lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
      For i = 13 To 23
         iLastRow = Cells(Rows.Count, i).End(xlUp).Row
         If lastRow = 1 Then
            Range(Cells(1, i), Cells(iLastRow, i)).Copy .Cells(lastRow, 1)
         Else
            Range(Cells(1, i), Cells(iLastRow, i)).Copy .Cells(lastRow + 1, 1)
         End If
         lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
      Next
   End With
End Sub


Макрос взят и немного переделан из темы Перенос данных из двух столбцов в один
Заранее благодарен за помощь, в макросах совсем дилетант.
Изменено: kos-mos - 27.04.2015 14:40:29
 
ну так файл приложите с ошибками, что есть что нужно.....
 
Код
Sub Macros1()
Dim lastRow As Long, c As Range
Application.ScreenUpdating = False
For Each c In Range(Cells(1, 13), Cells(Rows.Count, 23).End(xlUp)).Columns
  c.Copy
  With Sheets("Лист2")
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If Not IsEmpty(.Cells(lastRow, 1)) Then lastRow = lastRow + 1
    .Cells(lastRow, 1).PasteSpecial xlPasteValues
  End With
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Вместо
Код
Range(Cells(1, i), Cells(iLastRow, i)).Copy .Cells(lastRow, 1)

пишите
Код
                Range(Cells(1, i), Cells(iLastRow, i)).Copy
                .Cells(lastRow, 1).PasteSpecial xlPasteValues

и так везде.
Я сам - дурнее всякого примера! ...
 
Казанский, Спасибо. Ваш вариант отлично работает. добавил еще очистку столбца перед вставкой. Теперь то что нужно.
Код
Sub Macros1()
Dim lastRow As Long, c As Range
Application.ScreenUpdating = False

Sheets("Лист2").Range("A:A").ClearContents

For Each c In Range(Cells(1, 13), Cells(Rows.Count, 23).End(xlUp)).Columns
  c.Copy
  With Sheets("Лист2")
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If Not IsEmpty(.Cells(lastRow, 1)) Then lastRow = lastRow + 1
    .Cells(lastRow, 1).PasteSpecial xlPasteValues
  End With
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Изменено: kos-mos - 28.04.2015 00:05:47
Страницы: 1
Наверх