Copy workbook and to paste below another workbook MS Excel - excel

First I open a SubWorkbook than copy data from worksheet to update MainWorkbook (paste below):
The problem occur when I try to set variable for worksheet from the workbook I just open. It said: "Subscript out of Range".
What happen to it and how I can fix it, or is it wrong direction that I have to go from another way.
Sub Data_Inbound()
Dim mywb As Workbook
Dim FName As String
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Set mywb = ActiveWorkbook
On Error GoTo errHandler:
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xlsx*", Title:="Please select an Excel file")
Workbooks.Open FileName:=FName
Set wsCopy = Workbooks(FName).Worksheets(Sheet1)
Set wsDest = Workbooks(mywb).Worksheets(Sheet1)
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsCopy.Range("A2" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
wsDest.Activate
errHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Data_Inbound"
Exit Sub
End Sub
I see other guy they have the same question, but they use worksheet name, for me I use a variant variable, but it lead to error:
Other guy:
Set wsCopy = Workbooks("Warranty Template.xlsm").Worksheets("PivotTable")

Copy/Paste From Closed Workbook
The code has run successfully if you see the message. If not, something went wrong, and there is a message in the Immediate window CTRL+G.
The Code
Option Explicit
Sub Data_Inbound()
' Initialize error handling.
Const ProcName As String = "Data_Inbound"
' Do not use error handling while developing the code.
On Error GoTo clearError ' Turn on error trapping.
' Define Destination Workbook.
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Workbook Name.
Dim srcName As String
srcName = Application.GetOpenFilename(filefilter:="Excel Files,*.xlsx*", _
Title:="Please select an Excel file")
' Open Source Workbook (No variable, but it is the active one).
Workbooks.Open Filename:=srcName
' Define Source Worksheet ('wsSource').
Dim wsSource As Worksheet
Set wsSource = ActiveWorkbook.Worksheets("Sheet1") ' Note the double quotes.
' Define Destination Worksheet ('wsDest')
Dim wsDest As Worksheet
Set wsDest = wb.Worksheets("Sheet1") ' Note the double quotes...
' ... and not: Set wsDest = Workbooks(wb).Worksheets("Sheet1") - wrong!
' Define Source Last (Non-Empty) Row ('srcLastRow').
Dim srcLastRow As Long
srcLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
' Define Destination First (Empty (available)) Row ('destFirstRow').
Dim destFirstRow As Long
destFirstRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
' Copy from Source to Destination.
wsSource.Range("A2:A" & srcLastRow).Copy wsDest.Range("A" & destFirstRow)
' Note "A2:A" and not: "A2" - wrong!
' Now you wanna close the Source Workbook, but how?
' You can use the 'Parent' property:
wsSource.Parent.Close False ' False means not to save changes.
' If you closed, wsDest is active again so you don't need:
'wsDest.Activate
' Inform user, so you know the code has finished.
MsgBox "Copied data.", vbInformation, "Success"
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub

Related

How do I prompt a user for an excel sheet copy everything on the first sheet and then paste it to the Active Sheet?

Essentially my problem is that I have an already open workbook that I am running the VBA code from. I want to prompt the user to open a csv excel file, copy everything in the first sheet (I don't know what the sheet name is) and then paste everything from that sheet to a sheet in my Active Workbook. Right now the code will prompt the user and will allow them to select a csv but I get an error on the line:
Workbooks(FileToOpen).Activate
The error reads
"Subscript out of range"
Thanks for helping me on this.
Sub Popular()
FileToOpen = Application.GetOpenFilename _
(Title:="Please Choose the RTCM File", _
FileFilter:="Excel Files *.csv (*.csv),")
If FileToOpen = False Then
MsgBox "No file specified.", vbExclamation, "Duh!!!" ' Notification that nothing
is chosen
Exit Sub
Else ' Load the file, copy the first sheet and paste it in active sheet ...
ThisWorkbook.Activate
ThisWorkbook.ActiveSheet.Range("A1:Z65536").ClearContents
Workbooks(FileToOpen).Activate
lrow = Workbooks(FileToOpen).Sheets("Sheet1").Cells(65536, 1).End(xlUp).Row
Workbooks(FileToOpen).Sheets("Sheet1").Range("A1:Z" & lrow).Copy
ThisWorkbook.Activate
ThisWorkbook.ActiveSheet.Range("A1").PasteSpecial xlPasteValues
End If
End Sub
There are 3 problems in your code.
The reference to the "Sheet1", as you said you do not know the name so you should addres it per index (1).
and you used the full path in the reference to a workbook where this should be the name of the file.
You did not open the file you wanted to copy. I opened it in read only mode
Also get used to declare local variables because you end up in a mess not doing so
Option Explicit
Sub Popular()
Dim FileToOpen As Variant
Dim lrow As Long
Dim newWorkbook As Workbook
FileToOpen = Application.GetOpenFilename _
(Title:="Please Choose the RTCM File", _
FileFilter:="Excel Files *.csv (*.csv),")
If FileToOpen = False Then
MsgBox "No file specified.", vbExclamation, "Duh!!!" ' Notification that nothing is chosen
Exit Sub
Else ' Load the file, copy the first sheet and paste it in active sheet ...
ThisWorkbook.Activate
ThisWorkbook.ActiveSheet.Range("A1:Z65536").ClearContents
Set newWorkbook = Application.Workbooks.Open(FileToOpen, , True)
newWorkbook.Activate
lrow = newWorkbook.Sheets(1).Cells(65536, 1).End(xlUp).Row
newWorkbook.Sheets(1).Range("A1:Z" & lrow).Copy
ThisWorkbook.Activate
ThisWorkbook.ActiveSheet.Range("A1").PasteSpecial xlPasteValues
End If
End Sub
Import Data From a .csv File
Option Explicit
Sub ImportData()
' Reference the destination workbook ('dwb').
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
' Attempt to reference the destination worksheet ('dsh'),
' a worksheet in the workbook containing this code.
Dim dsh As Object: Set dsh = ActiveSheet
If dsh Is Nothing Then
MsgBox "No visible workbooks open.", vbCritical
Exit Sub
End If
If Not dsh.Parent Is dwb Then
MsgBox "Select a worksheet in the workbook '" & dwb.Name & "'.", _
vbCritical
Exit Sub
End If
If dsh.Type <> xlWorksheet Then
MsgBox "'" & dsh.Name & "' is not a worksheet.", vbCritical
Exit Sub
End If
' Let the user select the source file (workbook).
Dim sFilePath As Variant: sFilePath = Application.GetOpenFilename _
(Title:="Please Choose the RTCM File", _
FileFilter:="Excel Files (*.csv),*.csv")
If sFilePath = False Then
MsgBox "No file specified.", vbExclamation, "Duh!!!"
Exit Sub
End If
' Open and reference the source workbook ('swb').
Dim swb As Workbook: Set swb = Workbooks.Open(Filename:=sFilePath)
' If your list delimiter and the file delimiter are a semicolon (';'),
' use the following instead:
'Set swb = Workbooks.Open(Filename:=sFilePath, Local:=True)
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = swb.Worksheets(1) ' the one and only
' Reference the source range ('srg'), the range to be read from.
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A1", sws.Cells(slRow, "Z"))
' Clear previous destination data.
dsh.Range("A:Z").ClearContents
' Reference the destination range ('drg'), the range to be written to,
' a range of the same size as the source range.
Dim dfCell As Range: Set dfCell = dsh.Range("A1")
Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
' Copy values (by assignment).
drg.Value = srg.Value
' Close the source workbook.
swb.Close SaveChanges:=False ' it was just read from, nothing to save
' Save the destination workbook.
'dwb.Save
' Inform.
MsgBox "Data imported.", vbInformation
End Sub

VBA send cells value to another sheets next empty cell

I am trying to send a ticker from one workbook to another when ever it is one I would like to track. When I send it to the other workbook I want to paste the ticker in the next open cell in column JW.
So far my code is as follows:
Sub S2WL()
Dim lst As Long
Dim myVar As String
myVar = ActiveWorkbook.Activesheet.Range(“C2”).Value
With Workbooks("Dash").Sheet("DASH")
lst = .Range("JW" & Rows.Count).End(xlUp).Row + 1
.Range("JW" & lst).PasteSpecial xlPasteValues
End With
End Sub
I'm still very new to VBA and it fails when attempting to pull from my active sheet in workbook Fundamentals. I have multiple sheets that are basically copies in fundamentals. I want a general macro to send C2's value for whatever sheet I am on in Fundamentals to my watchlist in the Workbook Dash column JW. And each time to the next open cell in that column.
Thank you for any and all help!
Copy Value From the Active Sheet
A Qick Fix
Sub S2WLFixed()
Dim MyValue As Variant: MyValue = ThisWorkbook.ActiveSheet.Range("C2").Value
With Workbooks("Dash.xlsx").Worksheets("Dash")
Dim lst As Long: lst = .Cells(.Rows.Count, "JW").End(xlUp).Row + 1
.Cells(lst, "JW").Value = MyValue
End With
End Sub
An Improvement
The following covers most of the issues you may encounter when using the previous code.
Sub S2WL()
' 1. Define constants.
Const ProcName As String = "S2WL" ' for the message boxes
' s - Source (read from)
Const sCellAddress As String = "C2"
' d - Destination (write to)
Const dwbName As String = "Dash.xlsx" ' check if file extension is correct!
Const dwsName As String = "Dash"
Const dColumn As String = "JW"
' 2. Reference the source...
' Reference the workbook containing this code ('swb').
Dim swb As Workbook: Set swb = ThisWorkbook
' Reference the active sheet ('ash').
Dim ash As Object: Set ash = ActiveSheet
' Validate that the active sheet is in the source workbook.
If Not ash.Parent Is swb Then
MsgBox "The active sheet '" & ash.Name & "' is not located in the '" _
& swb.Name & "' workbook.", vbCritical, ProcName
Exit Sub
End If
' Validate that the active sheet is a worksheet.
If ash.Type <> xlWorksheet Then
MsgBox "The active sheet '" & ash.Name & "' is not a worksheet.", _
vbCritical, ProcName
Exit Sub
End If
' Reference the source cell ('sCell').
Dim sCell As Range: Set sCell = ash.Range(sCellAddress)
' 3. Reference the destination...
' Validate the destination workbook ('dwb').
Dim dwb As Workbook
On Error Resume Next
Set dwb = Workbooks(dwbName)
On Error GoTo 0
If dwb Is Nothing Then
MsgBox "The destination workbook '" & dwbName & "' is not open.", _
vbCritical, ProcName
Exit Sub
End If
' Validate the destination worksheet ('dws').
Dim dws As Worksheet
On Error Resume Next
Set dws = dwb.Worksheets(dwsName)
On Error GoTo 0
If dws Is Nothing Then
MsgBox "The destination worksheet '" & dwsName _
& "' does not exist in the '" & dwbName & "' workbook.", _
vbCritical, ProcName
Exit Sub
End If
' Reference the destination cell ('dCell').
Dim dCell As Range
Set dCell = dws.Cells(dws.Rows.Count, dColumn).End(xlUp).Offset(1)
' 4. Copy.
' Write the value from the source cell to the destination cell.
dCell.Value = sCell.Value
' Save the destination workbook (decide on your own).
'dwb.Save
' 5. Inform.
MsgBox "Value copied.", vbInformation
End Sub

Copying worksheet from personal workbook to active workbook (with macro in personal macro workbook)

I want to copy a worksheet from my personal workbook to my active workbook, with a macro (saved in personal macro workbook).
The problem in the code below is here: Workbooks("excel1.xlsx"). In my case the file name is non-constant. But the constant is this: I always have 2 workbooks open, the personal workbook and this non-constant workbook. And I work in the latter one.
Is it possible to alter the above, so that I don't need the file name? Maybe if I refer to it as the always open workbook instead?
Sub Macro1()
Windows("PERSONAL.XLSB").Activate
Sheets("Attributes").Select
Sheets("Attributes").Copy After:=Workbooks("excel1.xlsx").Sheets(1)
End sub
Copy Worksheet to Another Workbook
It will loop through all open workbooks and copy the worksheet to the first workbook that is not hidden (credits to Rory in the comments) and isn't the source workbook (PERSONAL.xlsb).
It doesn't matter which workbook is active.
Here are some undesired scenarios covered in the code:
the worksheet doesn't exist in the source,
there is no destination workbook (only the source workbook is open),
the worksheet already exists in the destination workbook.
The error-handling routine will cover possible other undesired scenarios.
Option Explicit
Sub InsertAttributesWorksheet()
Const ProcName As String = "InsertAttributesWorksheet"
On Error GoTo ClearError
Const wsName As String = "Attributes"
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
' Check if the worksheet exists in the source workbook.
Dim sws As Worksheet
On Error Resume Next
Set sws = swb.Worksheets(wsName)
On Error GoTo ClearError
If sws Is Nothing Then ' doesn't exist in source
MsgBox "The worksheet '" & wsName & "' doesn't exist " _
& "in the source workbook '" & swb.Name & "'.", _
vbCritical, ProcName
Exit Sub
'Else ' exists in source
End If
Dim swbName As String: swbName = swb.Name
' (the first workbook that is not hidden and is not the source workbook)
Dim dwb As Workbook
For Each dwb In Workbooks
If Windows(dwb.Name).Visible = True Then ' is not a hidden workbook
If dwb.Name <> swbName Then ' is not the source workbook
' Check if the worksheet exists in the destination workbook.
Dim dws As Worksheet
On Error Resume Next
Set dws = dwb.Worksheets(wsName)
On Error GoTo ClearError
If dws Is Nothing Then ' doesn't exist in destination
sws.Copy After:=dwb.Sheets(1)
MsgBox "The worksheet '" & wsName & "' was added " _
& "to the workbook '" & dwb.Name & "'.", _
vbInformation, ProcName
Exit Sub
Else ' already exists in destination
MsgBox "The worksheet '" & wsName & "' already exists " _
& "in the destination workbook '" & dwb.Name & "'.", _
vbCritical, ProcName
Exit Sub
End If
'Else ' is the source workbook
End If
'Else ' is a hidden workbook
End If
Next dwb
MsgBox "No other workbook found.", vbExclamation, ProcName
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub

Object Doesn't Support this Property or Method When copying from another workbook

I'm trying to write a small code in Excel that lets me open in the background another workbook, copy a range of data in there, and then pasty it in the active workboo. Should be pretty straight forward but for some reason I'm getting this error. So far what I've got is this, and I know the error comes from this line "cpyLastRow = ImportBook.cpySheet.Cells(3, 1).End(xlDown).Row", Ive got some variables commented to make it a little bit mor dyanimc in the future. Any ideas?
Private Sub CommandButton2_Click()
Dim OpenFile As Variant
Dim ImportBook As Workbook
Dim cpySheet As Worksheet
Dim cpyLastRow As Long
Dim cpyLastColumn As Long
'Dim cpyStartCell As Range
Set cpySheet = Sheets("DAO")
'Set cpyStartCell = Range("C3")
Application.ScreenUpdating = False
OpenFile = Application.GetOpenFilename(Title:="Select a file to import data", filefilter:="Excel Files (*.xls*),*xls*")
If OpenFile <> False Then
Set ImportBook = Application.Workbooks.Open(OpenFile)
cpyLastRow = ImportBook.cpySheet.Cells(3, 1).End(xlDown).Row
'cpyLastColumn = cpyStartCell.Column
ImportBook.cpySheet.Range("C3", cpySheet.Cells(cpyLastRow, 3)).Copy
ThisWorkbook.ActiveSheet.Range("C3").PasteSpecial xlPasteValues
ImportBook.Close False
End If
Application.ScreenUpdating = True
End Sub
You get an error due to mixing import workbook property and active worbook sheet reference. Try to use method 1 or method 2. Be sure to specify actual sheet name in the import workbook.
'get reference to sheet "ABF - DAO" in active workbook
Set cpySheet = Sheets("ABF - DAO")
...
'error: mix workbook property and sheet reference
cpyLastRow = ImportBook.cpySheet.Cells(3, 1).End(xlDown).Row
'method 1: get reference to sheet in import workbook
Set cpySheet = ImportBook.Sheets("ABF - DAO")
cpyLastRow = cpySheet.Cells(3, 1).End(xlDown).Row
'method 2: get last row without sheet reference
cpyLastRow = ImportBook.Sheets("ABF - DAO")
Copy Column Range From Closed Workbook
Option Explicit
Private Sub CommandButton2_Click()
Const ProcName As String = "CommandButton2_Click"
On Error GoTo clearError
Const sTitle As String = "Select a file to import data"
Const sFilter As String = "Excel Files (*.xls*),*xls*"
Const sName As String = "DAO"
Const sFirst As String = "C3"
Const dFirst As String = "C3"
Dim dSuccess As Boolean
' Source
' Path
Dim sPath As Variant
sPath = Application.GetOpenFilename(Title:=sTitle, FileFilter:=sFilter)
If sPath = False Then
MsgBox "You canceled.", vbExclamation, "Canceled"
GoTo ProcExit
End With
Application.ScreenUpdating = False
' Worksheet
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
On Error Resume Next
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
On Error GoTo 0
If sws Is Nothing Then
CloseWithoutSaving swb
MsgBox "The worksheet '" & sName & "' does not exist.", _
vbCritical, "No Worksheet"
GoTo ProcExit
End If
' Range
Dim fCell As Range: Set fCell = sws.Range(sFirst)
With fCell
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
CloseWithoutSaving swb
MsgBox "No data.", vbCritical, "No Data"
GoTo ProcExit
End If
Dim srg As Range: Set srg = .Resize(lCell.Row - .Row + 1)
End With
' Destination
' Assuming that the button is on the Destination Worksheet.
Dim dCell As Range: Set dCell = Range(dFirst)
' Otherwise, you should do something like this:
'Set dCell = ThisWorkbook.Worksheets("DAO").Range(dFirst)
' Copy (by Assignment)
dCell.Resize(srg.Rows.Count).Value = srg.Value
CloseWithoutSaving swb
dSuccess = True
ProcExit:
If Not Application.ScreenUpdating Then
Application.ScreenUpdating = True
End If
If dSuccess Then
MsgBox "Data transferred.", vbInformation, "Success"
End If
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
Sub CloseWithoutSaving( _
ByVal wb As Workbook)
Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True
End Sub

Keep Source Formatting after Sheets Split

Please can someone tell me how to keep the source format for the files created using the below macro. When I open the new files the colours have all changed compared to the original and I need these to match.
Sub SaveSheets()
' Save sheets as seperate workbooks
' Keyboard Shortcut: Ctrl+Shift+W
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sht As Object 'Could be chart, worksheet, Excel 4.0 macro,etc.
Dim strSavePath As String
On Error GoTo ErrorHandler
Application.ScreenUpdating = False 'Don't show any screen movement
strSavePath = "C:\Users\Joe Bloggs\Documents\Save Sheets\" 'Change this to suit your needs
Set wbSource = ActiveWorkbook
For Each sht In wbSource.Sheets
sht.Copy
Set wbDest = ActiveWorkbook
wbDest.SaveAs (strSavePath & sht.Name)
wbDest.Close 'Remove this if you don't want each book closed after saving.
Next
Application.ScreenUpdating = True
Exit Sub
ErrorHandler: 'Just in case something hideous happens
MsgBox "An error has occurred. Error number=" & Err.Number & ". Error description=" & Err.Description & "."
End Sub

Resources