I am trying to create a macro to auto filter on a named range. I have the following code:
Sub Filter()
Dim vCrit As Variant
Dim wsO As Worksheet
Dim wsL As Worksheet
Dim rngCrit As Range
Dim rngOrders As Range
Set wsO = Worksheets("Historical Holdings")
Set wsL = Worksheets("Control")
Set rngOrders = wsO.Range("$A$1").CurrentRegion
Set rngCrit = wsL.Range("Filter_Range")
vCrit = rngCrit.Value
rngOrders.AutoFilter _
Field:=1, _
Criteria1:=Application.Transpose(vCrit), _
Operator:=xlFilterValues
End Sub
The macro works, but it filters everything out instead on selecting the values in the named range. Does anyone know what I am doing wrong?
Related
I have a problem in a macro. It is an Excel, which after a filtering, copies the data in another Excel book. It is giving me the problem when I declare destiny, but I do not know what the problem is.
Could you help me?
Sub EnviarDatosVictoria()
Dim wbLibroActual, wbLibroVictoria, wbLibroNuevo As Workbook
Dim wsHojaActual, wsHojaVictoria As Worksheet
Dim RangoDatos As Range
Dim uFila As Long
Dim RutaDestino As String
RutaDestino = "Victoria.xlsx"
'Datos Libro Actual
Set wbLibroActual = Workbooks(ThisWorkbook.Name)
Set wsHojaActual = wbLibroActual.ActiveSheet
'Cogemos el rango que queremos copiar, que es todo lo usado
Set RangoDatos = wsHojaActual.UsedRange
'Establecemos el filtro
RangoDatos.AutoFilter Field:=34, Criteria1:="OTRA"
'Contamos el numero de filas (hasta la ultima)
uFila = wsHojaActual.Range("A" & Rows.Count).End(xlUp).Row
'Copiar datos de filtro
wsHojaActual.Range("A1:AM" & uFila).Copy
'Datos Destino'
Set wbLibroVictoria = Workbooks.Open(RutaDestino)
Set wsHojaVictoria = wbLibroVictoria.Worksheets("Hoja1")
wbHojaVictoria.Paste
Application.CutCopyMode = False
Windows(wbLibroActual.Name).Activate
wsHojaActual.Range("A1").Select
Selection.AutoFilter
End Sub
The error is this:
I see lot of problems with this code. BTW this not how you set your autofilter range OR apply the filter OR copy the Filtered results OR open another workbook....
Is this what you are trying? I have commented the code so you should not face any problems. This code is UNTESTED so if you spot an error, let me know and I will amend it. I am assuming that Row 1 has headers.
Sub EnviarDatosVictoria()
Dim wbThis As Workbook, wbThat As Workbook
Dim wsThis As Worksheet, wsThat As Worksheet
Dim wbThatPath As String
Dim rngToCopy As Range, rngAutofilter As Range
Dim lRow As Long
'~~> Change path accordingly
wbThatPath = "C:\Temp\Victoria.xlsx"
Set wbThis = ThisWorkbook
'~~> Change the name of the sheet as applicable
Set wsThis = wbThis.Sheets("Sheet1")
With wsThis
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngAutofilter = .Range("A1:AM" & lRow)
'~~> Remove any filters
.AutoFilterMode = False
With rngAutofilter
'~~> Filter, offset(to exclude headers) and copy visible rows
.AutoFilter Field:=34, Criteria1:="OTRA"
'~~> Set your copy range
Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Check if there is something in the copyrange or not
'~~> If there is then open another workbook
If Not rngToCopy Is Nothing Then
Set wbThat = Workbooks.Open(wbThatPath)
Set wsThat = wbThat.Sheets("Hoja1")
'~~> Copy Headers
wsThis.Rows(1).Copy wsThat.Rows(1)
'~~> Copy Filtered data
rngToCopy.Copy wsThat.Rows(2)
End If
Application.CutCopyMode = False
End Sub
I am trying to copy the data from one workbook to another workbook.
I searched through Internet and came up with the below code. there is no error in the code.
The code works fine, but the Problem is, it is opening both the Sheets , but not copying the data in Destination sheet.
in the code below, I have considered x as source sheet and y as Destination sheet.
Could someone suggest, where i am wrong and what is the reason i am not able to copy.
Sub test()
Dim x As Workbook
Dim y As Workbook
Dim val As Variant
Dim filename As String
Set x = Workbooks.Open("D:\Mikz\xxx.xlsx")
Set y = Sheets("Sheet1").Select
val = x.Sheets("Sheet2").Range("A1").Value
y.Sheets("Sheet1").Range("A1").Value = val
x.Close
End Sub
The reason for your error, lies in the section below:
Dim y As Workbook
Set y = Sheets("Sheet1").Select
You defined y as workbook, but trying to assign a Worksheet object to it, and you added Select for some reason, which is defiantly not recommended.
It should be (if the workbook is open) :
Set y = Workbooks("YourBookName")
The rest of your code would work just fine.
However, reading your post, I think you meant to define y As Worksheet.
And then the rest of your code should be:
Set y = Sheets("Sheet1")
val = x.Sheets("Sheet2").Range("A1").Value
y.Range("A1").Value = val
Edit 1: Updated code (according to PO's new data)
Option Explicit
Sub test()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Mikz\xxx.xlsx")
Val = x.Sheets("Sheet2").Range("A1").Value
y.Sheets("Sheet1").Range("A1").Value = Val
x.Close
End Sub
Edit 2: Code to copy columns A:E till last row with data
Option Explicit
Sub test()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Dim LastCell As Range
Dim LastRow As Long
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Mikz\xxx.xlsx")
With x.Sheets("Sheet2")
' use the find method to get the last row in column A:E
Set LastCell = .Columns("A:E").Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then ' find was successful
LastRow = LastCell.Row ' get last Row with data
End If
Val = .Range("A1:E" & LastRow).Value ' save range in 2-D array
End With
' resize the range from A1 through column E and the last row with data in copied workbook
y.Sheets("Sheet1").Range("A1").Resize(LastRow, 5).Value = Val
x.Close
End Sub
Try:
Sub test()
Dim wb As Workbook
Dim sht As Worksheet, sht2 As Worksheet
Set wb = Workbooks.Open("Filename")
Set sht = wb.Worksheets("Sheet2")
Set sht2 = ThisWorkbook.Worksheets("Sheet1")
sht2.Range("A1").Value = sht.Range("A1").Value
wb.Close
End Sub
But it should throw syntax errors and type mismatches before. Dont use .Select, its not necessary for any functions or task, it can be done without.
I'm making some sparklines and I'm trying to reference a range for the source data. The Problem is that the Range is added onto every month. I need to be able to use a range from a known first cell to until it finds a value.Offset(0,-1)
Dif wb As Workbook
Dif ws As Worksheet
Set wb = Workbooks("HardDrive location")
Set ws = wb.Worksheets("Sheet1")
wb.ws.Range.Rows(4).Cells.Find("XXX").Offset(0, 1).Select
Selection.SparklineGroups.Add Type:=xlSparkLine, SourceData:= Range("D4", wb.ws.Range.Rows(4).Find("XXX").Offset(0,-1))
'Other Parameters are below, but there aren't any problems past this point'
Not really sure how to get that to work. Any help would be appreciated.
EDITED:
Sub Test()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Sheet1")
Set rng = ws.Rows(4).Cells.Find("XXX").Offset(0, -1)
Range(rng.Offset(0, 1).Address).SparklineGroups.Add Type:=xlSparkLine, SourceData:=Range("D4" & ":" & rng.Address).Address
End Sub
I have written a macro to copy and paste several cell values from one worksheet to another. This has been successful on all fields except one containing a date value.
For example when the cell contains '08-Jan-14' the pasted value is an integer '41647'.
How do I ensure the pasted value received by the new worksheet will be in date format?
Sub place_data(Source As Worksheet, Destination As Worksheet, Optional WorkbookName As String,
Optional rowToWrite As Integer)
Dim iSourceHeader As Integer
Dim iCol As Integer
Dim lSourceEnd As Long
Dim lDestEnd As Long
Dim rSource As Range
Dim rDestination As Range
Dim rngFrom As Excel.Range
Dim rngTo As Excel.Range
Set rngFrom = Workbooks(WorkbookName).Sheets(Source.Name).Range("D51")
Set rngTo = ThisWorkbook.Sheets("Self Test Summary").Range("A" & rowToWrite)
rngFrom.Copy
rngTo.PasteSpecial Paste:=xlValues
You are just pasting the values and not the formats. You need to add one more line after pasting
rngFrom.Copy
rngTo.PasteSpecial Paste:=xlValues
rngTo.Numberformat = "DD-MMM-YY"
Another Way
rngTo.Value = rngFrom.Value
rngTo.Numberformat = "DD-MMM-YY"
replace:
rngFrom.Copy
rngTo.PasteSpecial Paste:=xlValues
with:
rngFrom.Copy rngTo
similar questions have been asked but I think I have a different problem:
Workbooks.Open Filename:=filepath & "PLT.xlsx"
Worksheets("Sheet1").Range(Worksheets("Sheet1").Range("A1:B1"), Worksheets("Sheet1").Range("A1:B1").End(xlDown)).Copy
Windows("XXX.xslm").Activate
w1.Range("A4").PasteSpecial Paste:=xlPasteValues
The second line is the problem. In fact, it does not copy the cells I want. When I open that workbook, the whole worksheet is selected.
I do not understand why I get that error.
Yikes. If you want to copy values to it the easy way:
Global fso As New FileSystemObject
Public Sub CopyValuesTest()
' Get references to the files
Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = Workbooks.Open(fso.BuildPath(filepath, "PLT.xlsx"))
Set wb2 = Workbooks("XXX")
' Get references to the sheets
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = wb1.Sheets("Sheet1")
Set ws2 = wb2.Sheets("Sheet1")
' Count non-empty rows under A1. Use 2 columns
Dim N As Integer, M As Integer
N = CountRows(ws1.Range("A1")): M = 2
' This copies the values
ws2.Range("A4").Resize(N, M).Value = ws1.Range("A1").Resize(N, M).Value
End Sub
Public Function CountRows(ByRef r As Range) As Long
If IsEmpty(r) Then
CountRows = 0
ElseIf IsEmpty(r.Offset(1, 0)) Then
CountRows = 1
Else
CountRows = r.Worksheet.Range(r, r.End(xlDown)).Rows.Count
End If
End Function
And make sure your filepath is defined. Also to use FileSystemObject see https://stackoverflow.com/a/5798392/380384