I am copying a range from all open workbooks with the goal of pasting the copied cells into a consolidated sheet in the master (active) workbook. I need to paste the values only but get an "end of line" error message with this code
Spent pretty much all day googling my problem to no avail
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
Get an error message at the PasteSpecial line. Everything works fine without the paste special but, as the copied range includes formulas, I do not get the values which is what I need.
.Copy and .PasteSpecial have to be done in 2 different lines but you concatenated the lines with _
copyFrom.Copy _
DstSht.Range("A" & DstRow).PasteSpecial xlPasteValues
Change it to:
copyFrom.Copy 'no line concatenation here !
DstSht.Range("A" & DstRow).PasteSpecial xlPasteValues
For more information see the documentation:
Range.Copy method
Range.PasteSpecial method / Worksheet.PasteSpecial method
Related
I am trying to make a macro where I separate my tabs (one from each client) into new excel files and then also filter, copy and paste (from a sheet called database) in each of those excel files just created the informations regarding each client.
When I try to run the code, it separate the tabs just as expected, but it does not copy and paste the information from my database sheet. I got the following error: "Application-defined or object-definied error" for the line "For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))"
How can I fix it?
Sub Separar_guias()
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
'Specify sheet name in which the data is stored
sht = "database"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count, "AA").End(xlUp).Row
With Workbk.Sheets(sht)
Set rng = .Range("A1:T" & last)
End With
Workbk.Sheets(sht).Range("AA1:AA" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
' Loop through unique values in column
For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=27, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
'Add New Workbook in loop
Set newBook = Workbooks.Add(xlWBATWorksheet)
newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
'Save new workbook
newBook.SaveAs x.Value & ".xlsx"
'Close workbook
newBook.Close SaveChanges:=False
Next x
' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
This script loops through each value within a filtered column with the aim of filtering one by one, copy the data, create a new workbook, paste it and save it.
It it now creating a signle new workbook with all the worksheets, instead of one workbook per worksheet.
Can someone point out how can I mend the code to create one workbook per value filtered?
On the other hand, the workbook is also keeping the original sheet1. I am also looking on how to remove it, but thought it would be importat to let you know.
Sub test()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
' -------------------
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
Dim ws As Worksheet
'Specify sheet name in which the data is stored
sht = "Report"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate
Set ws = Workbk.Worksheets(sht)
'change filter column in the following code
last = ws.Cells(Rows.Count, "BR").End(xlUp).Row
With ws
Set rng = .Range("A1:BR" & last)
End With
ws.Range("G1:G" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BT1"), Unique:=True
For Each x In ws.Range([BT2], Cells(Rows.Count, "BT").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
newBook.Sheets.Add(After:=newBook.Sheets(newBook.Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' -------------------
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Check."
End Sub ```
Put the Workbooks.Add line inside the loop.
Option Explicit
Sub test()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsNew As Worksheet
Dim rng As Range, cel As Range
Dim iLastRow As Long, iLastRowBT As Long
Dim folder As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Workbook where VBA code resides
Set wb = ThisWorkbook
Set ws = wb.Sheets("Report")
folder = wb.Path & "\"
With ws
'change filter column in the following code
iLastRow = .Cells(Rows.Count, "BR").End(xlUp).Row
.Range("BT:BT").Clear
.Range("G1:G" & iLastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("BT1"), Unique:=True
Set rng = .Range("A1:BR" & iLastRow)
iLastRowBT = .Cells(Rows.Count, "BT").End(xlUp).Row
End With
' create workbooks
For Each cel In ws.Range("BT2:BT" & iLastRowBT)
' Open New Workbook
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Sheets(1)
wsNew.Name = cel.Value
' filter and copy data
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=cel.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
' paste and save
wsNew.Paste
wbNew.SaveAs folder & cel.Value & ".xlsx"
wbNew.Close SaveChanges:=False
Next
' Turn off filter
ws.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
MsgBox iLastRowBT - 1 & " Workbooks created in " & folder, vbInformation
End Sub
I have a folder named "Import" I want to fill up with xls files and import them all at once. The files have the same structure and just require an easy copy and paste to the last cell of my master sheet. With a specific file path it works, but I am not sure how to loop it.
Edit: I tried to implement the Loop. It worked once. After I deleted the data and tried to import them again, I run into 1004 errors, because the Script has a problem with the row "Set UserWorkbook = Application.Workbooks.Open(UserFilename)".
Do I have a logic issue here?
Sub Import_VDL_v2_Button()
'Disable features'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
'Set the target file for import.'
Dim TargetWorkbook As Workbook
Set TargetWorkbook = Application.ActiveWorkbook
'Specifing file directory.'
Dim UserFilename As String
UserFilename = Dir("/Users/Name/Documents/Reporting/Data/Import/" & "*.xls*")
'Start Loop for import.'
Do While Len(UserFilename) > 0
UserFilename = Dir
Dim UserWorkbook As Workbook
Set UserWorkbook = Application.Workbooks.Open(UserFilename)
'Define source and target sheet for copy.'
Dim SourceSheet As Worksheet
Set SourceSheet = UserWorkbook.Worksheets(1)
Dim TargetSheet As Worksheet
Set TargetSheet = TargetWorkbook.Worksheets(1)
'Check for filter and if present, clear all filter in source sheet.'
If SourceSheet.AutoFilterMode = True _
Then SourceSheet.AutoFilter.ShowAllData
'Unhide all rows and columns in source sheet'
SourceSheet.Columns.EntireColumn.Hidden = False
SourceSheet.Rows.EntireRow.Hidden = False
'Copy data from source to last row in target sheet.'
Dim SourceLastRow As Long
SourceLastRow = SourceSheet.Cells(SourceSheet.Rows.Count, "A").End(xlUp).Row
Dim TargetLastRow As Long
TargetLastRow = TargetSheet.Cells(TargetSheet.Rows.Count, "A").End(xlUp).Offset(1).Row
SourceSheet.Range("A2:S" & SourceLastRow).Copy
TargetSheet.Range("A" & TargetLastRow).PasteSpecial xlPasteValues
'Close import file and save active file.'
UserWorkbook.Close
ActiveWorkbook.Save
Loop
'Enable features'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
I found the code below on this site which works perfectly once I referenced the appropriate cells etc. However, I tried to modify it to keep formulas but I am not having much luck. Any help is greatly appreciated.
Sub test()
Dim names As New Collection
Dim ws As Worksheet, ws1 As Worksheet
Dim wb As Workbook
Dim lastrow As Long
Dim cell As Range
Dim nm As Variant
Dim res As Range
Dim rngHeader As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'change "A" to column with "Names"
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'change "A" to column with "Names"
For Each cell In .Range("A2:A" & lastrow)
On Error Resume Next
'collect unique names
names.Add CStr(cell.Value), CStr(cell.Value)
On Error GoTo 0
Next cell
'disable all filters
.AutoFilterMode = False
'change "A1:C1" to headers address of your table
Set rngHeader = .Range("A1:C1")
For Each nm In names
With rngHeader
'Apply filter to "Name" column
.AutoFilter Field:=1, Criteria1:=nm
On Error Resume Next
'get all visible rows
Set res = .Offset(2).Resize(lastrow - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'if there is visible rows, create new WB
If Not res Is Nothing Then
'create new workbook
Set wb = Workbooks.Add
'add sheet with name form column "Names" ("Paul", "Nick" or etc)
wb.Worksheets.Add.name = nm
'delete other sheets from new wb
For Each ws1 In wb.Worksheets
If ws1.name <> nm Then ws1.Delete
Next
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Value = rngHeader.Value
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Value = res.Value
End With
'save wb
wb.Close saveChanges:=True, Filename:=ThisWorkbook.Path & "\Spreadsheet_" & nm & ".xlsx"
Set wb = Nothing
End If
End With
Next
'disable all filters
.AutoFilterMode = False
End With
Set names = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There is a part in your code which states that it copies / pastes data:
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Formula = rngHeader.Formula
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Formula = res.Formula
End With
If you copy the .Formula instead of the .Value then it should work. Give it a try and let us know.
I found this excellent code however I need to adapt it for my purposes.
Firstly I need to open a data workbook that is on our network. The problem I have is that it is likely at times to be open by another user and will offer the option of "read only". How can I get it to accept the read-only option so that I can commence extracting the data.
Secondly it copies using the "=" . How can I change it to copy just the values?
First macro:
Sub test()
'to open another workbook
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\Schedule.xls"
ThisWorkbook.Activate
Application.ScreenUpdating = True
End Sub
2nd Macro:
Dim Sh As Worksheet
Dim Newsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Delete the sheet "Summary-Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("Summary-Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Summary-Sheet"
Set Basebook = ThisWorkbook
Set Newsh = Basebook.Worksheets.Add
Newsh.Name = "Summary-Sheet"
'The links to the first sheet will start in row 2
RwNum = 1
For Each Sh In Basebook.Worksheets
If Sh.Name <> Newsh.Name And Sh.Visible Then
ColNum = 1
RwNum = RwNum + 1
'Copy the sheet name in the A column
Newsh.Cells(RwNum, 1).Value = Sh.Name
For Each myCell In Sh.Range("A1,D5:E5,Z10") '<--Change the range
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & myCell.Address(False, False)
Next myCell
End If
Next Sh
Newsh.UsedRange.Columns.AutoFit
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
You could always open the workbook as read-only if you are only extracting data.
Instead of using .formula use .value