My code aims to import an .xls file selected by the user, and copy and paste it into my Data sheet in Book 1. This Book 1 has 2 sheets: Results and Data.
I want to run the code when I am in Results and here comes the problem.
When I run it in my Data sheet, after clearing the current sheet (Data) the file is imported and copied well.
However, when I import it when I am in the Results sheet, it comes an error according to the MsgBox Err.Description
What's wrong in the code?
Sub ImportData()
Dim customerBook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook
Dim wb As Workbook
On Error Resume Next
Set wb = Application.Workbooks("Book1.xlsm")
wb.Activate
wb.Sheets("Data").Range("A1:M5000").Select
Selection.ClearContents
Sheets("Data").Select
Range("A1").Select
Set targetWorkbook = Application.ActiveWorkbook
filter = "Text files (*.xls),*.xls"
caption = "Please Select an Input File "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.ActiveSheet
Dim sourceSheet As Worksheet
Set sourceSheet = customerWorkbook.ActiveSheet
sourceSheet.UsedRange.Copy targetSheet.Range("A1")
sourceSheet.UsedRange.Value = sourceSheet.UsedRange.Value
targetSheet.Paste
customerWorkbook.Saved = True
customerWorkbook.Close
Sheets("Results").Select
End Sub
You may try it like this...
Sub ImportData()
Dim filter As String
Dim caption As String
Dim customerFilename As Variant
Dim customerWorkbook As Workbook, targetWorkbook As Workbook
Dim targetSheet As Worksheet, sourceSheet As Worksheet
Set targetWorkbook = Application.Workbooks("Book1.xlsm")
Set targetSheet = targetWorkbook.Sheets("Data")
targetSheet.Range("A1:M5000").ClearContents
filter = "Text files (*.xls),*.xls"
caption = "Please Select an Input File "
customerFilename = Application.GetOpenFilename(filter, , caption)
If customerFilename = False Then
MsgBox "No Customer File was selected.", vbExclamation
Exit Sub
End If
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
Set sourceSheet = customerWorkbook.ActiveSheet
sourceSheet.UsedRange.Copy
targetSheet.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = 0
sourceSheet.UsedRange.Value = sourceSheet.UsedRange.Value
customerWorkbook.Saved = True
customerWorkbook.Close
targetWorkbook.Sheets("Results").Select
End Sub
The following code:
wb.Sheets("Data").Range("A1:M5000").Select
Selection.ClearContents
Should be replaced with:
wb.Sheets("Data").Range("A1:M5000").ClearContents
The same goes for all similar lines. Operating on selection most often comes from macro recorder, is a very unreliable and slow method. It's dependent on currently selected range or object and non-transparent in the code, as it forces to know what is currently selected / active.
Selecting should be done only to leave selected worksheet or cell active in the end of macro operation or to perform actions on ActiveWindow.
Likewise, try to eliminate ActiveSheet:
Set targetSheet = targetWorkbook.ActiveSheet
And replace it with one of the following examples:
Set targetSheet = targetWorkbook.Worksheets(1) '1st worksheet in the file
Set targetSheet = targetWorkbook.Worksheets("myData") 'worksheet named "myData"
Related
I'm attempting to write a program to loop through a directory of excel files and copy a range into a "Master Workbook". When I run the program I am prompted with "Code execution has been interrupted". If I select continue the code will successfully run but then a "run-time error '-2147221080' Automation error" appears.
The line that causes the error is:
Set ws = wb.Worksheets("Project Log")
My question is, why is this line causing the error and or is there a way to bypass the error prompt so that my code will successfully run?
Sub FileCompiler()
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim ws as Worksheet
'set workbook in which data will be copied to
Set Masterwb = ActiveWorkbook
'declare path
'folderPath = "C:MyPath\"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
'compile directory data to master spreadsheet
Filename = Dir(folderPath & "*.xls*")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
Set ws = wb.Worksheets("Project Log")
ws.Range(ws.Cells(2, "C"), ws.Cells(2, "C")).Copy
Masterwb.Worksheets("Staging").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
ws.Range(ws.Cells(7, "A"), ws.Cells(Rows.Count, "K").End(xlUp)).Copy
Masterwb.Worksheets("Staging").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
wb.Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
Dim Finfo As String
Dim FilterIndex As Long
Dim Title As String
Dim CopyBook As Workbook
Dim CopySheet As Worksheet
Dim ForecastFileName As Variant
Dim MasterSheet AS Worksheet
Set MasterSheet = ThisWorkbook.Worksheets("Yoursheetname")
'now you can always use master sheet after you set copybook
'Set up file filter
Finfo = "Excel Files (*.xls*),*.xls*"
'Set filter index to Excel Files by default in case more are added
FilterIndex = 1
' set Caption for dialogue box
Title = "Hey there!, select a file"
'get the Forecast Filename
ForecastFileName = Application.GetOpenFilename(Finfo, FilterIndex, Title)
'Change this according to what you need for workbook and worksheet names
Workbooks.Open (ForecastFileName)
Set CopyBook = ActiveWorkbook
Set CopySheet = CopyBook.Worksheets(1)
'Do your code, remember to close
CopyBook.Close savechanges:=False 'Not needed now
You might want to check for the ForecastFileName being False, that is when the users x's out, you will also want to do a little validation the wb sheet is in the right format by checking column headers ect or you will wind up crashing.
I managed to get this working but some of my client files are protected.
Sub VBA_Read_External_Workbook()
' Get customer workbook...
Dim customerBook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook
Dim sheet As String
' make weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook
' get the customer workbook
filter = "Text files (*.xlsb),*.xlsb"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
sheet.Unprotect ("CADDRP")
' assume range is A1 - C10 in sheet1
' copy data from customer to target workbook
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
Dim sourceSheet As Worksheet
Set sourceSheet = customerWorkbook.Worksheets(3)
targetSheet.Range("A1", "C10").Value = sourceSheet.Range("D85", "D95").Value
' Close customer workbook
customerWorkbook.Close
End Sub
I squeezed sheet.unprotect inside.
It gives me an error
"Object Required" Run time error '424'.
I'm guessing I missed some variable declaration in the process?
Assuming you need to Unprotect the Sheet, not the Workbook.. Remove the sheet.Unprotect line where you have it currently and put it back in after setting the SourceSheet:
Set sourceSheet = customerWorkbook.Worksheets(3)
sourceSheet.Unprotect ("CADDRP")
I'm pretty new to VBA and need some help with a project. I need to write a macro that reads the Sheet Name in Column C, and pastes the values from a source workbook to a range in a target workbook, which is specified in Column D.
So for example, it needs to copy the data in Sheet2 of Myworkbook book, and paste it into range of Theirworkbook Sheet2. The place where the range and sheet number information is stored in a separate workbook.
Edit: I've added a picture of what wbOpen looks like. This is it here.
Option Explicit
Sub PasteToTargetRange()
Dim arrVar As Variant 'stores all the sheets to get the copied
Dim arrVarTarget As Variant 'stores names of sheets in target workbook
Dim rngRange As Range 'each sheet name in the given range
Dim rngLoop As Range 'Range that rngRange is based in
Dim wsSource As Worksheet 'source worksheet where ranges are found
Dim wbSource As Workbook 'workbook with the information to paste
Dim wbTarget As Workbook 'workbook that will receive information
Dim strSourceFile As String 'location of source workbook
Dim strTargetFile As String 'location of source workbook
Dim wbOpen As Workbook 'Current open workbook(one with inputs)
Dim wsRange As Range 'get information from source workbook
Dim varRange As Range 'Range where values should be pasted
Dim i As Integer 'counter for For Loop
Dim wbkNewSheet As Worksheet 'create new worksheet if target workbook doesn't have
Dim wsTarget As Worksheet 'target workbook worksheet
Dim varNumber As String 'range to post
Set wbOpen = Workbooks.Open("WorkbookWithRanges.xlsx")
'Open source file
MsgBox ("Open the source file")
strSourceFile = Application.GetOpenFilename
If strSourceFile = "" Then Exit Sub
Set wbSource = Workbooks.Open(strSourceFile)
'Open target file
MsgBox ("Open the target file")
strTargetFile = Application.GetOpenFilename
If strTargetFile = "" Then Exit Sub
Set wbTarget = Workbooks.Open(strTargetFile)
'Activate transfer Workbook
wbOpen.Activate
Set wsRange = ActiveSheet.Range("C9:C20")
Set arrVarTarget = wbTarget.Worksheets
For Each varRange In wsRange
If varRange.Value = 'Target workbook worksheets
varNumber = varRange.Offset(0, -1).Value
Set wsTarget = X.Offset(0, 1)
wsSouce.Range(wsTarget).Value = varNumber
Else
wbkNewSheet = Worksheets.Add
wbkNewSheet.Name = varRange.Value
End If
Next
End Sub
Something like this (untested but should give you an idea)
Sub PasteToTargetRange()
'....omitted
Set wsRange = wbOpen.Sheets(1).Range("C9:C20")
For Each c In wsRange
shtName = c.Offset(0, -1).Value
Set wsTarget = GetSheet(wbTarget, shtName) 'get the target sheet
wbSource.Sheets(shtName).Range(c.Value).Copy wsTarget.Range(c.Value)
Next
End Sub
'Get a reference to a named sheet in a specific workbook
' By default will create the sheet if not found
Function GetSheet(wb As Workbook, ws As String, Optional CreateIfMissing As Boolean = True)
Dim rv As Worksheet
On Error Resume Next 'ignore eroror if no match
Set rv = wb.Worksheets(ws)
On Error GoTo 0 'stop ignoring errors
'sheet wasn't found, and should create if missing
If rv Is Nothing And CreateIfMissing Then
Set rv = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
rv.Name = ws
End If
Set GetSheet = rv
End Function
I have a macro that allows a user to browse and select multiple Excel files, after the user has selected the multiple Excel files, the content from multiple Excel files should be saved on the current active workbook, on one sheet. the content would be append one another.
The problem is that when the loop runs for the second time it complains with the range, it says the range should start at "A1".
here is my code below.
Sub Button3_Click()
Dim fileStr As Variant
Dim incount As Integer
Dim wbk1 As Workbook, wbk2 As Workbook
incount = 1
fileStr = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xlsx), *.xlsx", Title:="Get File", MultiSelect:=True)
For i = 1 To UBound(fileStr)
MsgBox fileStr(i), , GetFileName(CStr(fileStr(i)))
Set wbk1 = ActiveWorkbook
Set wbk2 = Workbooks.Open(fileStr(i))
wbk2.Sheets(1).Cells.Copy wbk1.Worksheets("Sheet3").Cells(incount, 1)
incount = Range("A" & Rows.Count).End(xlUp).Row
wbk2.Close
Next i
MsgBox incount
End Sub
Function GetFileName(fileStr As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(fileStr)
End Function
Error message:
Run-time error '1004'
To paste all cells from an Excel worksheet into the current worksheet,
you must paste into the first cell(A1 or R1C1)
The cells.copy copies the whole sheet of data to the row of 'incount' which means that there is not room on the destination for the 'whole source sheet' below the already pasted data
Try the following code which removes incount and just picks up the UsedRange:
Sub Button3_Click()
Dim fileStr As Variant
Dim wbk1 As Workbook, wbk2 As Workbook
Dim ws1 As Worksheet
fileStr = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xlsx), *.xlsx", Title:="Get File", MultiSelect:=True)
Set wbk1 = ActiveWorkbook
Set ws1 = wbk1.Sheets("Sheet3")
For i = 1 To UBound(fileStr)
MsgBox fileStr(i), , GetFileName(CStr(fileStr(i)))
Set wbk2 = Workbooks.Open(fileStr(i))
wbk2.Sheets(1).UsedRange.Copy ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row + 1, 1)
wbk2.Close
Next i
End Sub
Function GetFileName(fileStr As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(fileStr)
End Function
I am attempting to create a subroutine that prompts the user to select a workbook and then adds the first worksheet of the selected workbook as a tab in the existing (active) workbook. Then names the new tab "Data". Here is the code I am using so far:
Sub getworkbook()
' Get workbook...
Dim ws As Worksheet
Dim filter As String
Dim targetWorkbook As Workbook
Set targetWorkbook = Application.ActiveWorkbook
' get the customer workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
ws = Application.GetOpenFilename(filter, , caption)
ws.Add After:=Sheets(Sheets.Count)
ws.Name = "DATA"
End Sub
This code doesn't seem to be working and is returning the following error:
"ws.Add" method or With Block not set.
Any help is appreciated.
Thanks,
You have declared ws as a worksheet and GetOpenFilename is returning a File name. I would recommend reading my post in this link:
Is this what you are trying?
Note: I have not done any error handling. I am sure you can take care of that.
Sub getworkbook()
' Get workbook...
Dim ws As Worksheet
Dim filter As String
Dim targetWorkbook As Workbook, wb As Workbook
Dim Ret As Variant
Set targetWorkbook = Application.ActiveWorkbook
' get the customer workbook
filter = "Text files (*.xlsx),*.xlsx"
Caption = "Please Select an input file "
Ret = Application.GetOpenFilename(filter, , Caption)
If Ret = False Then Exit Sub
Set wb = Workbooks.Open(Ret)
wb.Sheets(1).Move After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
ActiveSheet.Name = "DATA"
End Sub