I am trying to create a macro which filters an export from our database, copying the filtered results to different sheets and then copying data from those new sheets across to another workbook for further processing. I have been using code from SO which has worked, but now I am trying to combine the two elements (filtering to new sheets, copy to workbooks) I am encountering some problems which as a newbie I haven't been able to solve!
Everytime I run the macro, I get a 'Subscript out of range' error on this line:
Set NAVImperial = NAVExport.Sheets("ROMAN IMPERIAL")
Even though there is definitely a worksheet with this name. Is this something to do with the use of ThisWorkbook?
Thanks in advance!
Sub Sortcodingv2()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String
'specify sheet name in which the data is stored
sht = "236"
'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:O" & last)
Sheets(sht).Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x
' Turn off filter
Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
Dim NAVExport As Workbook
Set NAVExport = ThisWorkbook
' Roman Imperial
Dim NAVImperial As Worksheet
Dim LIVEImperial As Workbook
Dim LIVEImperialSheet As Worksheet
Dim UniqueIDs As Range
Dim Descriptions As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Set NAVImperial = NAVExport.Sheets("ROMAN IMPERIAL")
Set LIVEImperial = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Imperial.xlsm")
Set LIVEImperialSheet = LIVEImperial.Sheets("LIVE Data")
With NAVImperial
LastRow = NAVImperial.Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDs = NAVImperial.Range("B2:B" & LastRow)
Set Descriptions = NAVImperial.Range("F2:F" & LastRow)
UniqueIDs.Copy
LIVEImperialSheet.Range("A2").PasteSpecial xlPasteValues
Descriptions.Copy
LIVEImperialSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEImperialSheet.Range("C2:O" & LastRow).FillDown
LIVEImperial.Close True
Application.ScreenUpdating = True
The issue is likely that the names don't exactly match, which is why I prefer to avoid Sheets("Name") whenever I can.
If NAVExport is ThisWorkbook then all of its sheets are able to be referenced using their project names, avoiding the use of Sheets("Name"). If you open the Project Explorer (Ctrl+R). You should see a list of worksheets under Microsoft Excel Objects. The default names are Sheet1, Sheet2, Sheet3, etc. Find the one with the name in brackets as ROMAN IMPERIAL and that is the sheet you want to reference.
Then, when writing your code, you can directly write Sheet1.Cells(... or Sheet1.Range(... and you don't need to write Sheets("ROMAN IMPERIAL") anymore.
Related
I'm trying to write this little macro to copy several sheets stored in an array and paste them as values to new workbook, maintaining sheets' names and order. I've found some solutions but not exactly matching my situation.
This is for excel macro where we try sending dashboard thru mail along with attachment but need to added sheet only paste values with same formatting
Option Explicit
Sub Send_Email_With_snapshot()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Summary")
ActiveWorkbook.RefreshAll
Worksheets(Array("Calculation", "Retailer Wise_Data", "TM Wise", "Channel_Base")).Copy
Worksheets("Calculation").Range("a1:Ax54").Copy
Worksheets("Calculation").Range("a1:Ax54").PasteSpecial _
Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With ActiveWorkbook
.SaveAs Filename:="E:\Automation\New folder\" & "RAEO_Dashboard_MTD.xlsx", FileFormat:=51
.Close savechanges:=True
Application.DisplayAlerts = False
Dim lr As Integer
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
sh.Range("A1:T120").Select
With Selection.Parent.MailEnvelope.Item
.to = "xyz.com"
.cc = ""
.Subject = sh.Range("AN14").Value
.attachments.Add "D:\RAEO_Dashboard_MTD.xlsx"
.send
End With
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
End With
End Sub
I wasn't sure if you meant when you wrote "with same formatting". If by that you mean cells formatting (eg. color, size, borders, visible/hidden propertie, etc.) then I added another section at the end of this answer to address that. However, if you only need number formats to stay the same, here is how you could do it.
Paste values and number formats
The 2 key elements here are:
To use .PasteSpecial Paste:=xlPasteValuesAndNumberFormats to paste values and number formats at the same time.
Use a For loop to go over your array of sheets.
Implemented this would look like this:
Sub CopySheetsValuesAndNumberFormats()
ActiveWorkbook.RefreshAll 'In case you have Pivot Tables to refresh
Dim ListOfSheets() As Variant
ListOfSheets = Array("Calculation", "Retailer Wise_Data", "TM Wise", "Channel_Base") 'Example list based on the question
Dim SourceWorkbook As Workbook
Set SourceWorkbook = ThisWorkbook 'Or Workbooks("Workbook Name")
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = Workbooks.Add
Dim i As Long
For i = LBound(ListOfSheets) To UBound(ListOfSheets)
Dim SourceSheet As Worksheet
Set SourceSheet = SourceWorkbook.Worksheets(ListOfSheets(i))
Dim DestinationSheet As Worksheet
Set DestinationSheet = DestinationWorkbook.Worksheets.Add(After:=DestinationWorkbook.Worksheets(DestinationWorkbook.Worksheets.Count)) 'Insert in last position
DestinationSheet.Name = SourceSheet.Name
Dim SourceRange As Range
Set SourceRange = SourceSheet.UsedRange
Dim DestinationRange As Range
Set DestinationRange = DestinationSheet.Range(SourceRange.Address)
'Paste values and number formats
SourceRange.Copy
DestinationRange.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Next i
'Delete initial sheets
For i = 1 To 3
On Error Resume Next
Application.DisplayAlerts = False
DestinationWorkbook.Worksheets("Sheet" & i).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Next i
End Sub
Paste values and cells formatting
In order to copy the formatting, you are going to have to copy from all Cells as opposed to from the UsedRange in the first section of this answer. The reason is that some columns might have some formatting that apply to all the cells inside a column, but not all these cells will be part of the UsedRange.
The only part of the code that you need to replace from the code above is the one starting with "Paste values and number formats". You would need to replace this part with the following:
'Paste values and cells formatting
SourceSheet.Cells.Copy
DestinationSheet.Cells.PasteSpecial Paste:=xlPasteAll
SourceRange.Copy
DestinationRange.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
I want to copy the value from current sheet to another workbooks with auto filter by creating new one, once I run the code I got the error:
Object variable or with block variable not set
Here's the code:
Sub copyvaluetoanothersheet()
Dim selectrange As Range
Dim wb As Workbook
Dim Dsheet As Worksheet
Dim Lastrow As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Add
Set Dsheet = wb.Worksheets(1)
Lastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
selectrange = Sheet2.Range("A2:BP" & Lastrow)
With Worksheets("Production data")
.AutoFilterMode = False
selectrange.AutoFilter field:="Branch", Criteria1:="Direct Response"
selectrange.SpecialCells(xlCellTypeVisible).EntireRow.Copy
End With
Dsheet.PasteSpecial xlPasteValues
Application.ScreenUpdating = True
End Sub
Many thanks
You must use Set when assigning object variables (you've done it elsewhere).
Set selectrange = Sheet2.Range("A2:BP" & Lastrow)
Note too that your mixture of sheet code names, tab names, and indexes is confusing, and that your code will error if nothing is visible.
Try following
Sub cpVisible()
Dim MyProdName As String
Dim FilteredRange As Range
Dim myArr As Variant
Sheets("Production Data").Range("$A$2:$BP$50000").AutoFilter Field:="Branch", Criteria1:="Direct Response"
Set FilteredRange = Sheets("Production Data").Range("$A$2:$BP$50000").SpecialCells(xlCellTypeVisible)
FilteredRange.Copy Sheets("Dsheet").Range("A1")
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've searched everywhere to see why I'm getting this error. Basically once I get to the last line the "Selection.AutoFill Destination:=Range("G2:M" & LR)" I get the error. The code works if in a separate sub, by itself. Therefore I'm assuming the code above it is somehow affecting it?
Sub Certainsheets()
Dim Wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim LR As Long
Dim rTable As Range
Dim strCellREF2Txt As String
Dim strFILEname As String
Dim WS As Worksheet
'copy from ThisWorkbook
'Set wb2 = Workbooks(2)
Set wb2 = Workbooks.Open("C:\Users\asharma\Desktop\Loan Application\Loan
Data.xls")
'To this
Set Wb1 = ThisWorkbook
'Copying data from Loan Data file
Set tbl = wb2.Sheets(1).Range("A1").CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Copy
'wb2.Sheets(1).Range("A1").CurrentRegion.Copy
'Pasting data into AOL DATA Tab
Wb1.Activate
Sheets("AOL DATA").Range("A10000").End(xlUp).Offset(1, 0).PasteSpecial
xlValues
'Wb1.Sheets(1).Range("A1").Select.PasteSpecial Paste:=xlPasteValues,
'Operation:=xlNone, SkipBlanks _
':=False, Transpose:=False
Application.CutCopyMode = False
wb2.Close
'REMOVING DUPLICATES
'Sheets("AOL DATA").Range("$A:$E").RemoveDuplicates Columns:=1, Header:=xlNo
'This part Autofills the formulas till the last row.
LR = Range("A" & Rows.Count).End(xlUp).Row
Sheets("AOL DATA").Range("G2:M2").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("G2:M" & LR)
End sub'
Any help would be appreciated
You need to qualify your ranges with the actual sheet, otherwise VBA will default to the ActiveSheet object which may not be what you're expecting in your code.
You can re-write your code as follows:
Sub Certainsheets()
Dim loanWorkbook As Excel.Workbook
Dim aolSheet As Excel.Worksheet
Dim dataTable As Excel.Range
Set loanWorkbook = Workbooks.Open("C:\Users\asharma\Desktop\Loan Application\Loan Data.xls")
Set aolSheet = ThisWorkbook.Sheets("AOL DATA")
Set dataTable = loanWorkbook.Sheets(1).Range("A1").CurrentRegion
With dataTable.Offset(1, 0)
aolData.Range("A" & aolData.Rows.Count).End(xlUp).Offset(1, 0).Value = _
.Resize(.Rows.Count - 1, .Columns.Count).Value
End With
loanWorkbook.Close
With aolSheet
.Range("G2:M2").AutoFill .Range("G2:M" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
End Sub
The AutoFill() method requires the source range to be included as part of the destination range. I suspect because of your code's reliance on ActiveSheet object that you're unknowingly specifying two ranges on different sheets, hence the code fails.
I'm currently doing VBA project which need to copy from a workbook to another, which the WBookPst is the workbook I firstly open (use) meanwhile WBookCopy is the workbook where I open based on the links where I got by listing all ".xslt" format in a File into my Sheet1 of my first workbook. Here is my code :
Sub SortFiles()
'Set up your variables and turn off screen updating.
'Dim iCounter As Integer
Application.ScreenUpdating = False
'Sort the rows based on the data in column C
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Dim WBookCopy As Workbook
Dim WBookPst As Workbook
Dim filePath As String
Dim sheetName As String
Dim sheetCopy As Worksheet
Dim sheetPate As Worksheet
Dim rngCopy As Range
Dim rngPst As Range
filePath = Range("B2").Value
Set WBookCopy = Workbooks.Open(filePath)
Columns(30).Insert
For i = 1 To Sheets.count
Cells(i, 30) = Sheets(i).Name
Next i
sheetName = Range("AD1").Value
Set sheetCopy = WBookCopy.Worksheets(sheetName)
Set rngCopy = sheetCopy.Range("A:AA").Copy
Set WBookPst = ThisWorkbook
Set sheetPaste = WBookPst.Worksheets("Sheet1").Activate
Set rngCopy = sheetPaste.Range("A:AA").Select
ActiveSheet.Paste
End Sub
At Set rngCopy = sheetCopy.Range("A:AA").Copy there's error "Objects required".
What does that mean?
By the way, is how I copy and paste the data between sheets correct?
The issue is that rngCopy is of type range and you can't set it equal to a method (copy). Remove the .Copy and you should be fine. You also don't need to set the worksheet out range to a variable. You could just do one line that says WBookCopy.SheetName.Range("A:AA").Copyand then another line to paste.
As #Wyatt mentioned - your copy\paste syntax is incorrect
Here are 2 ways to do it:
Worksheets("Sheet1").Range("A:AA").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteAll
or
Worksheets("Sheet1").Range("A:AA").Copy Destination:=Worksheets("Sheet2").Range("A1")