Я копирую диапазон из всех открытых рабочих книг с целью вставки скопированных ячеек в консолидированный лист в основной (активной) рабочей книге. Мне нужно только вставить значения, но получить сообщение об ошибке «конец строки» с этим кодом
Потратил почти весь день, пытаясь найти решение моей проблемы безрезультатно
Sub Consolidate()
Dim oBook As Workbook, ws As Worksheet, wb As Workbook, bk As Workbook
Dim copyFrom As Range
'Disable Screen Updating - stop screen flickering
' And Disable Events to avoid inturupted dialogs / popups
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True
'Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
DstSht.Name = "Consolidate_Data"
End With
'Loop through each WorkBook in the folder and copy the data to the 'Consolidate_Data' WorkSheet in the ActiveWorkBook
Set wb = ActiveWorkbook
For Each oBook In Application.Workbooks
If Not oBook.Name = wb.Name Then
'Find the last row on the 'Consolidate_Data' sheet
DstRow = fn_LastRow(DstSht) + 1
'Determine Input data range
Set copyFrom = oBook.Worksheets(1).Range("A6:C8")
'Copy data to the 'consolidated_data' WorkSheet
copyFrom.Copy _
DstSht.Range("A" & DstRow).PasteSpecial xlPasteValues
End If
Next
IfError:
'Enable Screen Updating and Events
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
'Find the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)
Dim lastRow As Long
lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
lRow = Sht.Cells.SpecialCells(xlLastCell).Row
Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
lRow = lRow - 1
Loop
fn_LastRow = lRow
End Function
Consolidate()
Dim oBook As Workbook, ws As Worksheet, wb As Workbook, bk As Workbook
Dim copyFrom As Range
'Disable Screen Updating - stop screen flickering
' And Disable Events to avoid inturupted dialogs / popups
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True
'Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
DstSht.Name = "Consolidate_Data"
End With
'Loop through each WorkBook in the folder and copy the data to the 'Consolidate_Data' WorkSheet in the ActiveWorkBook
Set wb = ActiveWorkbook
For Each oBook In Application.Workbooks
If Not oBook.Name = wb.Name Then
'Find the last row on the 'Consolidate_Data' sheet
DstRow = fn_LastRow(DstSht) + 1
'Determine Input data range
Set copyFrom = oBook.Worksheets(1).Range("A6:C8")
'Copy data to the 'consolidated_data' WorkSheet
copyFrom.Copy _
DstSht.Range("A" & DstRow).PasteSpecial xlPasteValues
End If
Next
IfError:
'Enable Screen Updating and Events
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
'Find the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)
Dim lastRow As Long
lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
lRow = Sht.Cells.SpecialCells(xlLastCell).Row
Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
lRow = lRow - 1
Loop
fn_LastRow = lRow
End Function
Получить сообщение об ошибке в строке PasteSpecial. Все отлично работает без специальной вставки, но, поскольку в копируемый диапазон входят формулы, я не получаю значения, которые мне нужны.