Set destination is error - vba

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

Related

Selecting a range that is from one cell to a found value?

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

Search for item in workbook A, if found, copy row to workbook B

I need to copy from workbook A to B based on a search string. The searching part seems to be ok from debugging but the copying is not working. Is there something that i have done wrongly?
Set wbThis = ActiveWorkbook
Set wsNewData = wbThis.Sheets("Sheet1")
lNextRow = 1
Set wbData = Application.Workbooks.Open(FileName, ReadOnly:=True)
ThisWorkbook.Activate
For Each ws In wbData.Worksheets
With ws
For Each Cell In ws.Range("H:H")
If Cell.Value = fWhat Then
matchRow = Cell.Row
'ws.Rows("8:" & matchRow).Select
'Selection.Copy
ws.Rows(matchRow, "8").Copy wsNewData.Rows(lNextRow)
wsNewData.Select
wsNewData.Rows(lNextRow).Select
wsNewData.Paste
lNextRow = lNextRow + 1
wbThis.Save
End If
Next
End With
Next
wbData.Close
Your code is redundant at some places. Though the biggest issue I think is going through every cell in the whole coloumn H, which takes a long time. Here is the code, cleaned up:
Set wbThis = ActiveWorkbook
Set wsNewData = wbThis.Sheets("Sheet1")
lNextRow = 1
Set wbData = Application.Workbooks.Open(FileName, ReadOnly:=True)
ThisWorkbook.Activate
For Each ws In wbData.Worksheets
For Each Cell In intersect(ws.Range("H:H"),ws.usedrange)
If Cell.Value = fWhat Then
ws.Rows(Cell.Row).Copy wsNewData.Rows(lNextRow)
lNextRow = lNextRow + 1
End If
Next
Next
wbThis.Save
wbData.Close 'you are closing this withouth saving. are you sure you want to do this???? just delete this line...
Another issue is that apparently you are really beginner in VBA, and in programming in general. Why don't you start with the macro recorder, and analyze the codes it records? Also, read up a bit on object oriented programming, and VBA too.
I'm sorry, but I can't explain everything I did, sinece I think I'd have to start with Adam and Eve...
Hope this works.
Also, next time, just do an autofilter, and record it with macro recorder. Will even be faster than this.
It looked like you were getting there but you had some methods mashed up and the copy seemed to be unclear as to the source and destinaton.
Dim wbThis As Workbook, wbData As Workbook
Dim ws As Worksheet, wsNewData As Worksheet
Dim cell As Range
Dim lNextRow As Long, matchRow As Long
Dim fWhat As String, fileName As String
fWhat = "thing to find"
fileName = Environ("TEMP") & Chr(92) & "myWorkBook.xlsb"
Set wbThis = ActiveWorkbook
Set wsNewData = wbThis.Sheets("Sheet1")
Set wbData = Application.Workbooks.Open(fileName, ReadOnly:=True)
lNextRow = 1
For Each ws In wbData.Worksheets
With ws
For Each cell In Intersect(.UsedRange, .Range("H:H"))
If cell.Value = fWhat Then
matchRow = cell.Row
.Rows(matchRow).Copy wsNewData.Rows(lNextRow).Cells(1)
lNextRow = lNextRow + 1
wbThis.Save
End If
Next cell
End With
Next ws
wbData.Close SaveChanges:=False
Set wbThis = Nothing
Set wsNewData = Nothing
Set wbData = Nothing
I've used a full row copy from the worksheet being examined to the next row on the wsNewData worksheet (Sheet1 of wbThis).
When you are within a With ... End With statement, you do not have to keep referencing the object the With ... End With references. Just preceed the ranges/.Rows, etc with a period anf they will know that the parent worksheet is the only referenced by the With ... End With.
I also had to invent a fileName and fWhat to look for. You will need to set hose yourself.

How to make this code not rely on the file name

I have this code that pulls data from 4 separate workbooks and paste them into the next empty section in a template workbook (FRF_Data_Macro_Insert_Test). This works perfectly but i have one issue, I need it to be able to paste in the active workbook and not to be dependent on the file name. Because this is a template and therefore read only, it prompts you to save as a different file name upon opening. I told the people using this to just cancel the first save as window and just save as when all done pulling data but they keep saving as before they pull data making it not work because its looking for FRF_Data_Macro_Insert_Test filename. Any help is much appreciated!
Thanks
Code:
Sub DataTransfer()
Const FPATH As String = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\"
Application.ScreenUpdating = False
Dim wb As Workbook
Dim shtAlpha As Worksheet 'Template
Dim locs, loc
Dim rngDest As Range
locs = Array("Location1.xls", "Location2.xls", _
"Location3.xls", "Location4.xls")
Set shtAlpha = Workbooks("FRF_Data_Sheet_Template.xlsm").Sheets("DataInput")
'set the first data block destination
Set rngDest = shtAlpha.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(5, 3)
For Each loc In locs
Set wb = Workbooks.Open(FileName:=FPATH & loc, ReadOnly:=True)
rngDest.Value = wb.Sheets("Data").Range("I3:K7").Value
wb.Close False
Set rngDest = rngDest.Offset(0, 3) 'move over to the right 3 cols
Next loc
Application.ScreenUpdating = True
End Sub
As your macro is in the workbook you want to reference, you can simply use ThisWorkbook:
Sub DataTransfer()
Const FPATH As String = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\"
Application.ScreenUpdating = False
Dim wb As Workbook
Dim shtAlpha As Worksheet 'Template
Dim locs, loc
Dim rngDest As Range
locs = Array("Location1.xls", "Location2.xls", _
"Location3.xls", "Location4.xls")
Set shtAlpha = ThisWorkbook.Sheets("DataInput")
'set the first data block destination
Set rngDest = shtAlpha.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(5, 3)
For Each loc In locs
Set wb = Workbooks.Open(Filename:=FPATH & loc, ReadOnly:=True)
rngDest.Value = wb.Sheets("Data").Range("I3:K7").Value
wb.Close False
Set rngDest = rngDest.Offset(0, 3) 'move over to the right 3 cols
Next loc
Application.ScreenUpdating = True
End Sub
I would post this as just a comment, but it won't let me.
I'm not sure if i'm following what you're asking right, but if it's a matter of just saving a separate copy with a different name automatically, then itt would be Workbooks("FRF_Data_Sheet_Template.xlsm").SaveCopyAs

Copy worksheets based on column value

I am fairly new with Excel vba but have been using access vba for some time now.
I have some code which splits a main file into several other files based on a distinct column in excel
Sub SplitbyValue()
Dim FromR As Range, ToR As Range, All As Range, Header As Range
Dim Wb As Workbook
Dim Ws As Worksheet
'Get the header in this sheet
Set Header = Range("D8").EntireRow
'Visit each used cell in column D, except the header
Set FromR = Range("D9")
For Each ToR In Range(FromR, Range("D" & Rows.Count).End(xlUp).Offset(1))
'Did the value change?
If FromR <> ToR Then
'Yes, get the cells between
Set All = Range(FromR, ToR.Offset(-1)).EntireRow
'Make a new file
Set Wb = Workbooks.Add(xlWBATWorksheet)
'Copy the data into there
With Wb.ActiveSheet
Header.Copy .Range("A8")
All.Copy .Range("A9")
End With
'Save it
Wb.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy.mm.dd") & _
" - " & FromR.Value & ".xls", xlWorkbookNormal
Wb.Close
'Remember the start of this section
Set FromR = ToR
End If
Next
End Sub
This works great for the main sheet, but have to copy multiple tabs and this only captures one sheet. How can I expand this so it copies the other sheets as well into that file?
example:
ColumnA
Id1
Id2
Id3
This creates three files (Id1)(Id2)(Id3) but ignores the other sheets.
Create an encompassing loop and define the worksheet being processed with a With...End With statement. You loop through a For Each...Next Statement using a Worksheet object on the Worksheets collection but I typically use the index of each worksheet.
Sub SplitbyValue()
Dim FromR As Range, ToR As Range, dta As Range, hdr As Range
Dim w As Long, ws As Worksheet, wb As Workbook, nuwb As Workbook
'Get the header in this sheet
Set wb = ActiveWorkbook
For w = 1 To wb.Worksheets.Count
With wb.Worksheets(w)
Set hdr = .Range(.Cells(8, "D"), .Cells(8, Columns.Count).End(xlToLeft))
'Visit each used cell in column D, except the header
Set FromR = .Range("D9")
For Each ToR In .Range(FromR, .Range("D" & Rows.Count).End(xlUp).Offset(1))
'Did the value change?
If FromR <> ToR Then
'Yes, get the cells between
Set dta = .Range(FromR, ToR.Offset(-1)).EntireRow
'Make a new file
Set nuwb = Workbooks.Add(xlWBATWorksheet)
'Copy the data into there
With nuwb.Sheet1
hdr.Copy .Range("A8")
dta.Copy .Range("A9")
End With
'Save it
nuwb.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy.mm.dd") & _
" - " & FromR.Value & ".xls", xlWorkbookNormal
nuwb.Close False
Set nuwb = Nothing
'Remember the start of this section
Set FromR = ToR
End If
Next ToR
End With
Next w
End Sub
I did not set up a full test environment but this should get you heading in the right direction. I've always found it unreliable to depend on ActiveSheet.
Here is a function that will allow you to search for a sheet and goto it by name.
Private Sub loopsheets(strSheetName As String)
iFoundWorksheet = 0
For iIndex = 1 To ea.ActiveWorkbook.Worksheets.Count
Set ws = ea.Worksheets(iIndex)
If UCase(ws.Name) = UCase(strSheetName) Then
iFoundWorksheet = iIndex
Exit For
End If
Next iIndex
If iFoundWorksheet = 0 Then
MsgBox "No worksheet was found with the name RESULTS (this is not case sensetive). Aborting."
End If
Set ws = ea.Worksheets(iFoundWorksheet)
ws.Activate
End Sub
If you want to just loop them all you just need the for loop.
Dim iIndex as Integer
For iIndex = 1 To ea.ActiveWorkbook.Worksheets.Count
Set ws = ea.Worksheets(iIndex)
ws.Activate
'Call your code here.
SplitbyValue
Next iIndex

Excel VBA activate worksheet

I need to activate a specific worksheet. The code is meant to create worksheets with a specif name. I need to paste something from a another worksheet into all these newly created worksheets. The code that I'm using is below. But I'm having a hard time activating the newly created worksheet to paste what I want.
Sub octo()
'Dim ws As Worksheet
Dim Ki As Range
Dim ListSh As Range
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\timesheet.xlsx")
With Worksheets("PPE 05-17-15")
Set ListSh = .Range("B4:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
On Error Resume Next
For Each Ki In ListSh
If Len(Trim(Ki.Value)) > 0 Then
If Len(Worksheets(Ki.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value
'open template
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\octo_template.xls")
Range("A1:L31").Select
Selection.Copy
Worksheets(Ki.Value).Activate
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
End If
End If
Next Ki
End Sub
Both Workbooks.Open and Worksheets.Add return references to the opened and added objects, which you can use to directly access and modify them - and in your case, to paste data.
Example:
Dim oSourceSheet As Worksheet
Dim oTargetSheet As Worksheet
Set oSourceSheet = Sheet1 'Set reference to any sheet, Sheet1 in my example
Set oTargetSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oSourceSheet.Range("A1:L31").Copy
oTargetSheet.Paste
Set oSourceSheet = Nothing
Set oTargetSheet = Nothing
I think that is what you need. As what been mentioned by chris, there is no need Activate or Select. Hope the following code solve your problem.
Option Explicit
Dim MyTemplateWorkbook As Workbook
Dim MyDataWorkbook As Workbook
Dim MyTemplateWorksheet As Worksheet
Dim MyDataWorksheet As Worksheet
Dim MyNewDataWorksheet As Worksheet
Dim CurrentRange As Range
Dim ListRange As Range
Sub AddWSAndGetData()
Set MyTemplateWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx")
Set MyTemplateWorksheet = MyTemplateWorkbook.Sheets("Template")
Set MyDataWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx")
Set MyDataWorksheet = MyDataWorkbook.Sheets("PPE 05-17-15")
Set ListRange = MyDataWorksheet.Range("B4:B" & MyDataWorksheet.Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
On Error Resume Next
For Each CurrentRange In ListRange
If Len(Trim(CurrentRange.Value)) > 0 Then
If Len(MyDataWorksheet(CurrentRange.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CurrentRange.Value
Set MyNewDataWorksheet = MyDataWorkbook.Sheets(ActiveSheet.Name)
MyNewDataWorksheet.Range("A1:L31").Value = MyTemplateWorksheet.Range("A1:L31").Value
If MyDataWorkbook.Saved = False Then
MyDataWorkbook.Save
End If
End If
End If
Next CurrentRange
MyTemplateWorkbook.Close (False) 'Close the template without saving
End Sub