Check if there's been data copied/pasted from a excel file (VBA) - vba

Im going to start by telling what my intention was with this code
In my job we have to open every sales order that will be sent in that day and check for the itens to be shipped manually.
Since its very time consuming i tought in creating a worksheet that it will look for the itens in every sales order and copy/paste in my master so i can know what i need to get.
However to my sheet works I had to make a few changes in the Sales order, but now I want to create a error check, that if the file that it was open was an older SO it will tell me its order number so later i can check it.
Also i want to check if by some reason nothing was found in that SO.
Now ill explain what my code does (I have a little knowledge in coding and in excel vba, so please dont judge my ugly script)
Using the value of a cell in a range, it will open the folder and file that matches it's value, then will look for a specific range and for a specific cell value, in this case "Perfil", if this value is found it will copy some cells.
After looking for that file it will open another one and do the same.
However if "Perfil" is not found it wont copy and paste anything and it will just go to the next file.
Public Sub test()
On Error GoTo Errormsg
Dim wbk As Workbook
Dim Fonte As Workbook
Dim Dest As Workbook
Dim Filename As String
Dim FolderName As String
Dim Arquivo As String
Dim Path As String
Dim celula As Range
Dim cll As Range
Dim Inicio As Range
Dim Fim As Range
Dim OffInicio As Range
Dim OffFim As Range
Dim busca As Range
Application.ScreenUpdating = False
Set Dest = Workbooks("testee.xlsm")
Path = 'My file path
lrow = Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).Row
For Each celula In Dest.Worksheets(1).Range("A3:A" & lrow)
Dest.Sheets(1).Activate
Pedido = Cells(celula.Row, 1)
FolderName = Pedido & "*"
Arquivo = "\" & Pedido
Folder = Dir(Path & FolderName, vbDirectory)
Filename = Dir(Path & Folder & Arquivo & "*.xlsx")
Set wbk = Workbooks.Open(Path & Folder & "\" & Filename, 0)
Set Fonte = Workbooks(Filename)
Fonte.Activate
Set Inicio = Fonte.Worksheets(1).Cells.Find(what:="MODO DE FIXAÇÃO DO PRODUTO")
Set Fim = Fonte.Worksheets(1).Cells.Find(what:="OBSERVAÇÕES")
Set OffInicio = Inicio.Offset(1, 0)
Set OffFim = Fim.Offset(-1, 1)
Set busca = Range(OffInicio, OffFim).Columns(5)
Set check = Range(OffInicio, OffFim).Columns(9)
Range(OffInicio, OffFim).Columns(5).Select
Set busca = Selection
For Each cl In busca
tipo = Cells(cl.Row, 5).Value
If tipo = "Perfil" Then
tamanho = Cells(cl.Row, 6).Value
expessura = Cells(cl.Row, 11).Value
cor = Cells(cl.Row, 12).Value
lrow2 = Dest.Sheets(2).Range("D" & Dest.Sheets(2).Rows.Count).End(xlUp).Row
linha = lrow2 + 1
Dest.Sheets(2).Range("D" & linha).Value = Pedido
Dest.Sheets(2).Range("E" & linha).Value = tamanho
Dest.Sheets(2).Range("H" & linha).Value = cor
End If
Next cl
End If
Next celula
Errormsg:
lrow2 = Dest.Sheets(2).Range("D" & Dest.Sheets(2).Rows.Count).End(xlUp).Row
linha = lrow2 + 1
Dest.Sheets(2).Range("D" & linha).Value = Pedido
Dest.Sheets(2).Range("E" & linha).Value = "Pedido com modelo Antigo"
End Sub
I want to know the files that no data has been copied, so I can check manually and see why it wasnt.
To do that i tought in checking if in that file any data has been copied and pasted in my master sheet, if nothing was done it will send a message in a cell telling its number so i can check it later.
Now is my question:
I dont know if is possible to check if anything was pasted from that file, in case is possible, how i do that?
I cant just check if "Perfil" exists because for my sheet works I had to change a few things in the sheets that had the data I needed, and "perfil"is not something that the older version of it had.
Also in my new version "Perfil"is not the only value that the column can have so i cant just check if perfil is not found there.

There are a few ways you can check if anything has changed in the workbook. I'd suggest this method:
In any (new or existing) standard module, add a public variable declaration at or near the top of the module:
Public wksChanged As Boolean
For each worksheet that you want to monitor for changes, open the Worksheet's module by right-clicking the worksheet's tab and clicking View Code:
...and then add this procedure (to each applicable worksheet module):
Private Sub Worksheet_Change(ByVal Target As Range)
wksChanged = True
End Sub
wksChanged will default to False when the workbook is first opened, and will change to True when any cell is changed. You can "reset" it at any time with:
wksChanged = False

Related

Excel vba: combine multiple files in one sheet

I have 100+ files in one folder. Each file has 3 lists, but only 1 list with data. I need to take that data from each file and combine it in a single file on 1 list. I wrote a sub for it, but I'm not sure how to go around selecting only the range needed (it varies from file to file) - in the same way you do it on keyboard with Ctrl + Shift + left arrow + down arrow. And how should I go around pasting it in the result workbook at exactly the first free line after the data that was pasted before?
Sub combine()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim ExcelApp As Object
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
ExcelApp.ScreenUpdating = False
ExcelApp.DisplayAlerts = False
ExcelApp.EnableEvents = False
'**VARIABLES**
Dim folderPath As String
folderPath = "Y:\plan_graphs\final\mich_alco_test\files\"
'COUNT THE FILES
Dim totalFiles As Long
totalFiles = 0
Dim fileTitle As String
fileTitle = Dir(folderPath & "*.xl??")
Do While fileTitle <> ""
totalFiles = totalFiles + 1
fileTitle = Dir()
Loop
'OPENING FILES
Dim resultWorkbook As Workbook
Dim dataWorkbook As Workbook
Set resultWorkbook = ExcelApp.Application.Workbooks.Open("Y:\plan_graphs\final\mich_alco_test\result.xlsx")
fileTitle = Dir(folderPath & "*.xl??")
'FOR EACH FILE
Do While fileTitle <> ""
Set dataWorkbook = ExcelApp.Application.Workbooks.Open(folderPath & fileTitle)
dataWorkbook.Worksheets("List1").Range("A1").Select
dataWorkbook.Worksheets("List1").Selection.CurrentRegion.Select
`resultWorkbook.Range
fileTitle = Dir()
Loop
ExcelApp.Quit
Set ExcelApp = Nothing
End Sub
I may have misunderstood the question and unfortunately I cannot make a comment. If I've grasped this question wrong, i'll delete.
but I'm not sure how to go around selecting only the range needed
This suggests that you have a dynamic amount of data and want to use Range to grab the selections.
Supposing you know the column location of where said data is located (in this case my list starts at B2 and we don't know where it ends. You can use Range to dynamically select all data:
Dim rcell As Range
Dim rng As Range
Set rng = ActiveSheet.Range("B2", Range("B2").End(xlDown))
For Each rcell In rng.Cells
Debug.Print rcell.Value
Next rcell
End Sub
First we define a Range variable and assign it to the range starting at B2 and using .End(xlDown) we can select a range ending at the final entry.
For further reading on .End() see here.
Hope this helps.
You can do this without VBA. Use Get & Transform instead.
Here are a few steps to get you started:
Go to the Data Tab
Under Get & Transform, pick New Query - From File - From Folder
Select the folder containing all your 100+ files
Select the tab that contains your data
You are almost there. Do your final fixes (if needed)
Once you're done, click Close & Load
This should do what you want.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
i have this Code VBA, its works, i can combine some files on one sheet.
check it!
Sub Open_Files()
Dim Hoja As Object
Application.ScreenUpdating = False
'Definir la variable como tipo Variante
Dim X As Variant
'Abrir cuadro de dialogo
X = Application.GetOpenFilename _
("Excel Files (*.xlsx), *.xlsx", 2, "Abrir archivos", , True)
'Validar si se seleccionaron archivos
If IsArray(X) Then ' Si se seleccionan
'Crea Libro nuevo
Workbooks.Add
'Captura nombre de archivo destino donde se grabaran los archivos seleccionados
A = ActiveWorkbook.Name
'*/********************
For y = LBound(X) To UBound(X)
Application.StatusBar = "Importando Archivos: " & X(y)
Workbooks.Open X(y)
b = ActiveWorkbook.Name
For Each Hoja In ActiveWorkbook.Sheets
Hoja.Copy after:=Workbooks(A).Sheets(Workbooks(A).Sheets.Count)
Next
Workbooks(b).Close False
Next
Application.StatusBar = "Listo"
Call Unir_Hojas
End If
Application.ScreenUpdating = False
End Sub

Excel Transform Sub to Function

I am quite new in VBA and wrote a subroutine that copy-paste cells from one document into another one. Being more precise, I am working in document 1 where I have names of several product (all in column "A"). For these product, I need to look up certain variables (e.g. sales) in a second document.
The subroutine is doing the job quite nicely, but I want to use it as a funcion, i.e. I want to call the sub by typing in a cell "=functionname(productname)".
I am grateful for any helpful comments!
Best, Andreas
Sub copy_paste_data()
Dim strVerweis As String
Dim Spalte
Dim Zeile
Dim findezelle1 As Range
Dim findezelle2 As Range
Dim Variable
Dim Produkt
'Variable I need to copy from dokument 2
Variable = "frequency"
'Produkt I need to copy data from document 2
Produkt = Cells(ActiveCell.Row, 1)
'path, file and shhet of document 2
Const strPfad = "C:\Users\Desktop\test\"
Const strDatei = "Bezugsdok.xlsx"
Const strBlatt = "post_test"
'open ducument 2
Workbooks.Open strPfad & strDatei
Worksheets(strBlatt).Select
Set findezelle = ActiveSheet.Cells.Find(Variable)
Spalte = Split(findezelle.Address, "$")(1)
Set findezelle2 = ActiveSheet.Cells.Find(Produkt)
Zeile = Split(findezelle2.Address, "$")(2)
'copy cell that I need
strZelle = Spalte & Zeile 'Zelladresse
strVerweis = "'" & strPfad & "[" & strDatei & "]" & strBlatt & "'!" & strZelle
'close document 2
Workbooks(strDatei).Close savechanges:=False
With ActiveCell
.Formula = "=IF(" & strVerweis & "="""",""""," & strVerweis & ")"
.Value = .Value
End With
End Sub
Here is an example to create a function that brings just the first 3 letters of a cell:
Public Function FirstThree(Cell As Range) As String
FirstThree = Left(Cell.Text, 3)
End Function
And using this in a Excel worksheet would be like:
=FirstThree(b1)
If the sub works fine and you just want to make it easier to call you can add a hotkey to execute the Macro. In the developer tab click on Macros then Options. You can then add a shortcut key (Crtl + "the key you want" it can be a shortcut key already used like C, V, S, but you will lose those functions (Copy, Paste Save, Print)
enter image description here

Making excel macro for file scanning more stable

I was curious if anybody could provide suggestions on how I can make an excel macro more stable.
The macro prompts the user for a path to a folder containing files to scan. The macro then iterates for every file in this folder.
It opens the excel file, scans Column D for the word fail, then copies that row of data to the data sheet in the excel file where this macro is programmed.
For the most part the macro runs perfectly but sometimes I get run time errors or 'excel has stopped working' errors. I can scan through 5000+ files at a time and the macro takes a while to run.
Any suggestions would be appreciated. Thanks!
Sub findFail()
Dim pathInput As String 'path to file
Dim path As String 'path to file after being validated
Dim fileNames As String 'path to test file
Dim book As Workbook 'file being tested
Dim sheet As Worksheet 'sheet writting data to
Dim sh As Worksheet 'worksheet being tested
Dim dataBook As Workbook 'where data is recorded
Dim row As Long 'row to start writting data in
Dim numTests As Long 'number of files tested
Dim j As Long 'counter for number of files tested
Dim i As Long 'row currently being tested
Dim lastRow As Long 'last row used
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Application.ScreenUpdating = False
j = 0
i = 1
row = 2
Set dataBook = ActiveWorkbook
Set sheet = Worksheets("Data")
sheet.Range("A2:i1000").Clear
startTime = Timer
'-----Prompt for Path-----
pathInput = InputBox(Prompt:="Enter path to files. It must have a \ after folder name.", _
Title:="Single Report", _
Default:="C:\Folder\")
If pathInput = "C:\Folder\" Or pathInput = vbNullString Then 'check to make sure path was inputed
MsgBox ("Please enter a valid file path and try again.")
Exit Sub
Else
path = pathInput 'path = "C:\Temp\212458481\" ' Path for file location
fileNames = Dir(path & "*.xls") 'for xl2007 & "*.xls?" on windows
'-----begin testing-----
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
lastRow = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).row
If sh.Cells(lastRow, 2).Value - sh.Cells(1, 2).Value >= 0.08333333 Then
Do While sh.Range("D" & i).Value <> "" 'loop untile there are no rows left to test
If sh.Range("D" & i).Value = "Fail" Then 'record values if test result is false
sheet.Range("A" & row).Value = book.Name
sheet.Range("B" & row).Value = Format(sh.Range("B" & i).Value - sh.Range("B1").Value, "h:mm:ss")
sheet.Range("C" & row).Value = sh.Range("A" & i).Value
sheet.Range("D" & row).Value = Format(sh.Range("B" & i).Value, "h:mm:ss")
sheet.Range("E" & row).Value = sh.Range("C" & i).Value
sheet.Range("F" & row).Value = sh.Range("D" & i).Value
sheet.Range("G" & row).Value = sh.Range("E" & i).Value
sheet.Range("H" & row).Value = sh.Range("F" & i).Value
sheet.Range("I" & row).Value = sh.Range("G" & i).Value
row = row + 1
Exit Do
End If
i = i + 1
Loop
j = j + 1
dataBook.Sheets("Summary").Cells(2, 1).Value = j
End If
book.Close SaveChanges:=False
fileNames = Dir()
i = 1
Loop
numTests = j
Worksheets("Summary").Cells(2, "A").Value = numTests
minsElapsed = Timer - startTime
Worksheets("Summary").Cells(2, "B").Value = Format(minsElapsed / 86400, "hh:mm:ss")
End If
End Sub
Without the same dataset as you we, can not definitively supply an answer but I can recommend the below which is related to the error you are seeing.
Try freeing/destroying the references to book and sh.
You have a loop that sets them:-
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
However the end of the loop does not clear them, ideally it should look as below:-
Set sh = Nothing
Set book = Nothing
Loop
This is a better way to handle resources and should improve memory usage.
As a poor example, without it your code is saying, sh equals this, now it equals this instead, now it equals this instead, now it equals this instead, etc...
You end up with the previous reference that was subsequently overwritten being a sort of orphaned object that is holding some space in memory.
Depending on your case, you may use the following to make it faster -by turning off excel processes that you don't really need at the time of your macro execution-
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.StatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
End Sub
In your sub
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Call ExcelBusy
...
As a comment, you never set back screenupdating to true in your sub, that may lead to strange behavior in excel, you should turn everything to default after you are done with your stuff.
OT: Some processes can't be optimized any further -sometimes-, by what you are saying -scanning over 5k files?- surely it's going to take a time, you need to work in how to communicate the user that is going to take a while instead -perhaps an application status bar message or a user form showing process?-.

Copy VBA code from a Sheet in one workbook to another?

I've been using the lines below to compy VBA modules from one workbook to another and I don't know if there is an easier way, but they have been working fine:
Set srcVba = srcWbk.VBProject
Set srcModule = srcVba.VBComponents(moduleName)
srcModule.Export (path) 'Export from source
trgtVba.VBComponents.Remove VBComponent:=trgtVba.VBComponents.Item(moduleName) 'Remove from target
trgtVba.VBComponents.Import (path) 'Import to target
However now I need to copy VBA code that is in a Sheet, not in a Module. The above method doesn't work for that scenario.
What code can I use to copy VBA code in a sheet from one workbook to another?
You can't remove and re-import the VBComponent, since that would logically delete the whole worksheet. Instead you have to use CodeModule to manipulate the text within the component:
Dim src As CodeModule, dest As CodeModule
Set src = ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
Set dest = Workbooks("Book3").VBProject.VBComponents("ThisWorkbook") _
.CodeModule
dest.DeleteLines 1, dest.CountOfLines
dest.AddFromString src.Lines(1, src.CountOfLines)
If anyone else lands here searching for VSTO equivalent of Chel's answer, here it is:
void CopyMacros(Workbook src, Workbook dest)
{
var srcModule = src.VBProject.VBComponents.Item(1).CodeModule;
var destModule = dest.VBProject.VBComponents.Add(Microsoft.Vbe.Interop.vbext_ComponentType.vbext_ct_StdModule);
destModule.CodeModule.AddFromString(srcModule.Lines[1, srcModule.CountOfLines]);
}
Things to note:
You must add reference to Microsoft.Vbe.Interop to do this stuff.
I'm adding a new general module to the destination workbook, so I didn't need to call DeleteLines. YMMV.
Patrick's code does not work for Worksheets (in fact, it will transfer the code to the wrong module). A workaround is to create a new sheet in the destination workbook, and then copy the code over (optionally you can copy and paste the worksheet data/functions/formatting as well).
The other thing that doesn't work is UserForms. You can copy the code over, but I'm not aware of any way to copy the actual form (including all the controls) without using the export/import method.
Expanding on Patrick's code:
'Needs reference to : Microsoft Visual Basic for Application Extensibility 5.3 ,
'or run this code : thisworkbook.VBProject.References.AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
'from immediate window (ctrl+G) or create a small sub
' What works: Successfully tranfsers Modules with code and name
' Copies userform code and name only, but the form is blank (does not transfer controls)
' Copies code in sheets but no content (optionally add code to copy & paste content)
' Successfully transfers Classes with code and name
Option Explicit
Public Sub CopyComponentsModules() 'copies sheets/Thisworkbook/Userforms/Modules/Classes to a new workbook
Dim src As CodeModule, dest As CodeModule
Dim i&
Dim WB_Dest As Workbook
Dim Ref As Reference
Dim Comp As VBComponent
Dim sht As Worksheet
Debug.Print "Starting"
Set WB_Dest = Application.Workbooks.Add
On Error Resume Next 'needed for testing if component already exists in destination WorkBook and for cross-references
For Each Comp In ThisWorkbook.VBProject.VBComponents
Debug.Print Comp.Name & " - "; Comp.Type
Err.Clear
'Set Source code module
Set src = Comp.CodeModule 'ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
'Test if destination component exists first
i = 0
i = Len(WB_Dest.VBProject.VBComponents(Comp.Name).Name)
If i <> 0 Then 'or: if err=0 then
Set dest = WB_Dest.VBProject.VBComponents(Comp.Name).CodeModule
Else 'create component
Err.Clear
If Comp.Type = 100 Then
Set sht = WB_Dest.Sheets.Add
Set dest = WB_Dest.VBProject.VBComponents(sht.Name).CodeModule
WB_Dest.VBProject.VBComponents(sht.Name).Name = Comp.Name
sht.Name = Comp.Name
Else
With WB_Dest.VBProject.VBComponents.Add(Comp.Type)
If Err.Number <> 0 Then
MsgBox "Error: Component " & Comp.Name & vbCrLf & Err.Description
Else
.Name = Comp.Name
Set dest = .CodeModule
End If
End With
End If
End If
If Err.Number = 0 Then
'copy module/Form/Sheet/Class 's code:
dest.DeleteLines 1, dest.CountOfLines
dest.AddFromString src.Lines(1, src.CountOfLines)
End If
Next Comp
'Add references as well :
For Each Ref In ThisWorkbook.VBProject.References
WB_Dest.VBProject.References.AddFromFile Ref.FullPath
Next Ref
Err.Clear: On Error GoTo 0
Set Ref = Nothing
Set src = Nothing
Set dest = Nothing
Set Comp = Nothing
Set WB_Dest = Nothing
End Sub
This is a compiled code from different sources as well from this very one Post.
My contribution is a code that copies ALL your codes from VBE (Sheets/Thisworkbook/Userforms/Modules/Classes) to a new Workbook.
i created this , because i have a corrupt workbook and making a code to recover all that isn't corrupt, including code. (this part only recovers code + references) :
'needs a reference to : Visual basic for Application Extensibility 5.3 ,
'or run this code : thisworkbook.VBProject.References.AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
'from immediate window (ctrl+G) or create a small sub
Option Explicit
Sub CopyComponentsModules() 'copies sheets/Thisworkbook/Userforms/Modules/Classes to a new workbook
Dim src As CodeModule, dest As CodeModule
Dim i&
Dim WB_Dest As Workbook
'Dim sh As Worksheet
Dim Comp As VBComponent
'Set sh = ThisWorkbook.Sheets(1)
'sh.Cells.Clear
Set WB_Dest = Application.Workbooks.Add
On Error Resume Next 'needed for testing if component already exists in destination WorkBook and for cross-references.
For Each Comp In ThisWorkbook.VBProject.VBComponents
'i = i + 1
'sh.Cells(i, 1).Value = Comp.Name
'Set Source code module
Set src = Comp.CodeModule 'ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
'test if destination component exists first
i = 0: i = Len(WB_Dest.VBProject.VBComponents(Comp.Name).Name)
If i <> 0 Then 'or: if err=0 then
Set dest = WB_Dest.VBProject.VBComponents(Comp.Name).CodeModule
Else 'create component
With WB_Dest.VBProject.VBComponents.Add(Comp.Type)
.Name = Comp.Name
Set dest = .CodeModule
End With
End If
'copy module/Form/Sheet/Class 's code:
dest.DeleteLines 1, dest.CountOfLines
dest.AddFromString src.Lines(1, src.CountOfLines)
Next Comp
'Add references as well :
Dim Ref As Reference
For Each Ref In ThisWorkbook.VBProject.References
'Debug.Print Ref.Name 'Nom
WB_Dest.VBProject.References.AddFromFile Ref.FullPath
'Debug.Print Ref.FullPath 'Chemin complet
'Debug.Print Ref.Description 'Description de la référence
'Debug.Print Ref.IsBroken 'Indique si la référence est manquante
'Debug.Print Ref.Major & "." & Ref.Minor 'Version
'Debug.Print "---"
Next Ref
Err.Clear: On Error GoTo 0
'WB_Dest.Activate
Set Ref = Nothing
Set src = Nothing
Set dest = Nothing
Set Comp = Nothing
Set WB_Dest = Nothing
End Sub

How to copy data from another workbook (excel)?

I already have a macro that creates sheets and some other stuff. After a sheet has been created do I want to call another macro that copies data from a second excel (its open) to first and active excel file.
First I want to copy to headers, but I cant get that to work - keep getting errors.
Sub CopyData(sheetName as String)
Dim File as String, SheetData as String
File = "my file.xls"
SheetData = "name of sheet where data is"
# Copy headers to sheetName in main file
Workbooks(File).Worksheets(SheetData).Range("A1").Select # fails here: Method Select for class Range failed
Workbooks(File).Worksheets(SheetData).Range(Selection, Selection.End(xlToRight)).Select
Workbooks(File).Worksheets(SheetData).Selection.Copy ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
End Sub
What is wrong ?
I really want to avoid having to make "my file.xls" active.
Edit: I had to give it up and copy the SheetData to target file as a new sheet, before it could work.
Find and select multiple rows
Two years later (Found this on Google, so for anyone else)... As has been mentioned above, you don't need to select anything. These three lines:
Workbooks(File).Worksheets(SheetData).Range("A1").Select
Workbooks(File).Worksheets(SheetData).Range(Selection, Selection.End(xlToRight)).Select
Workbooks(File).Worksheets(SheetData).Selection.Copy ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
Can be replaced with
Workbooks(File).Worksheets(SheetData).Range(Workbooks(File).Worksheets(SheetData). _
Range("A1"), Workbooks(File).Worksheets(SheetData).Range("A1").End(xlToRight)).Copy _
Destination:=ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
This should get around the select error.
Best practice is to open the source file (with a false visible status if you don't want to be bother) read your data and then we close it.
A working and clean code is avalaible on the link below :
http://vba-useful.blogspot.fr/2013/12/how-do-i-retrieve-data-from-another.html
Would you be happy to make "my file.xls" active if it didn't affect the screen? Turning off screen updating is the way to achieve this, it also has performance improvements (significant if you are doing looping while switching around worksheets / workbooks).
The command to do this is:
Application.ScreenUpdating = False
Don't forget to turn it back to True when your macros is finished.
I don't think you need to select anything at all. I opened two blank workbooks Book1 and Book2, put the value "A" in Range("A1") of Sheet1 in Book2, and submitted the following code in the immediate window -
Workbooks(2).Worksheets(1).Range("A1").Copy Workbooks(1).Worksheets(1).Range("A1")
The Range("A1") in Sheet1 of Book1 now contains "A".
Also, given the fact that in your code you are trying to copy from the ActiveWorkbook to "myfile.xls", the order seems to be reversed as the Copy method should be applied to a range in the ActiveWorkbook, and the destination (argument to the Copy function) should be the appropriate range in "myfile.xls".
I was in need of copying the data from one workbook to another using VBA. The requirement was as mentioned below 1. On pressing an Active X button open the dialogue to select the file from which the data needs to be copied. 2. On clicking OK the value should get copied from a cell / range to currently working workbook.
I did not want to use the open function because it opens the workbook which will be annoying
Below is the code that I wrote in the VBA. Any improvement or new alternative is welcome.
Code: Here I am copying the A1:C4 content from a workbook to the A1:C4 of current workbook
Private Sub CommandButton1_Click()
Dim BackUp As String
Dim cellCollection As New Collection
Dim strSourceSheetName As String
Dim strDestinationSheetName As String
strSourceSheetName = "Sheet1" 'Mention the Source Sheet Name of Source Workbook
strDestinationSheetName = "Sheet2" 'Mention the Destination Sheet Name of Destination Workbook
Set cellCollection = GetCellsFromRange("A1:C4") 'Mention the Range you want to copy data from Source Workbook
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
'.Filters.Add "Macro Enabled Xl", "*.xlsm;", 1
For intWorkBookCount = 1 To .SelectedItems.Count
Dim strWorkBookName As String
strWorkBookName = .SelectedItems(intWorkBookCount)
For cellCount = 1 To cellCollection.Count
On Error GoTo ErrorHandler
BackUp = Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount))
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = GetData(strWorkBookName, strSourceSheetName, cellCollection.Item(cellCount))
Dim strTempValue As String
strTempValue = Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)).Value
If (strTempValue = "0") Then
strTempValue = BackUp
End If
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = strTempValue
ErrorHandler:
If (Err.Number <> 0) Then
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = BackUp
Exit For
End If
Next cellCount
Next intWorkBookCount
End With
End Sub
Function GetCellsFromRange(RangeInScope As String) As Collection
Dim startCell As String
Dim endCell As String
Dim intStartColumn As Integer
Dim intEndColumn As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim coll As New Collection
startCell = Left(RangeInScope, InStr(RangeInScope, ":") - 1)
endCell = Right(RangeInScope, Len(RangeInScope) - InStr(RangeInScope, ":"))
intStartColumn = Range(startCell).Column
intEndColumn = Range(endCell).Column
intStartRow = Range(startCell).Row
intEndRow = Range(endCell).Row
For lngColumnCount = intStartColumn To intEndColumn
For lngRowCount = intStartRow To intEndRow
coll.Add (Cells(lngRowCount, lngColumnCount).Address(RowAbsolute:=False, ColumnAbsolute:=False))
Next lngRowCount
Next lngColumnCount
Set GetCellsFromRange = coll
End Function
Function GetData(FileFullPath As String, SheetName As String, CellInScope As String) As String
Dim Path As String
Dim FileName As String
Dim strFinalValue As String
Dim doesSheetExist As Boolean
Path = FileFullPath
Path = StrReverse(Path)
FileName = StrReverse(Left(Path, InStr(Path, "\") - 1))
Path = StrReverse(Right(Path, Len(Path) - InStr(Path, "\") + 1))
strFinalValue = "='" & Path & "[" & FileName & "]" & SheetName & "'!" & CellInScope
GetData = strFinalValue
End Function