I am trying to copy the values from one sheet, into another workbooks sheet. However I can't get Excel to actually paste the values to the other workbook.
This my code.
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook ' SOURCE
Dim currentWbk As Workbook ' WORKBOOK TO PASTE VALUES TO
Set src = openDataFile
Set currentWbk = ActiveWorkbook
'Clear existing data
currentWbk.Sheets(1).UsedRange.ClearContents
src.Sheets(1).Copy After:=currentWbk.Sheets(1)
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
And below is the function openDataFile which is used to get the source workbok (File Dialog):
Function openDataFile() As Workbook
'
Dim wb As Workbook
Dim filename As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
fd.Title = "Select the file to extract data"
' Optional properties: Add filters
fd.Filters.Clear
fd.Filters.Add "Excel files", "*.xls*" ' show Excel file extensions only
' means success opening the FileDialog
If fd.Show = -1 Then
filename = fd.SelectedItems(1)
End If
' error handling if the user didn't select any file
If filename = "" Then
MsgBox "No Excel file was selected !", vbExclamation, "Warning"
End
End If
Set openDataFile = Workbooks.Open(filename)
End Function
When I try to run my Sub, it opens the src file and just stops there. No values are copied and pasted to my currentWbk
What am I doing wrong?
Maybe my sub will help u
Public Sub CopyData()
Dim wb As Workbook
Set wb = GetFile("Get book") 'U need use your openDataFile here
Dim wsSource As Worksheet
Set wsSource = wb.Worksheets("Data")'enter your name of ws
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets.Add
wsSource.Cells.Copy ws.Cells
wb.Close False
End Sub
Related
I have a master Excel file that needs to inherit data from .csv files.
When I run the VBA, it will pop up the file explorer, let me select multiple files and loop over them and create new sheets.
When I try to copy the data into the sheet that it created, it gives me a type mismatch error.
Sub OpenLMSFiles()
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim tempWB As Workbook
Dim i As Integer
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "Libraries\Documents"
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
For i = 1 To fd.SelectedItems.Count
Set tempWB = Workbooks.Open(fd.SelectedItems(i))
Call ReadDataFromSourceFile(tempWB)
Next i
End If
End Sub
Private Sub ReadDataFromSourceFile(src As Workbook)
Application.ScreenUpdating = False
ThisWorkbook.Sheets.Add
Workbooks(src).Worksheets(src.ActiveSheet).Range("A1:Z500").Copy _
Workbooks(ThisWorkbook).Worksheets(ThisWorkbook.ActiveSheet).Range("A1:Z500")
End Sub
The cause of the error is the way you are referencing workbooks and worksheets, which are collections that take index arguments (integer or string). For example you can reference a workbook as Workbooks(1) (bad idea) or Workbooks("FileName.xlsx") (better). Similarly use Sheets(1) or Sheets("SheetName").
src is a Workbook -> simply use src.Sheets(). Because csv files have only 1 worksheet it is safe to use src.Worksheets(1) (Sheets and Worksheets are equivalent).
Anyway, here is a working code. I rearranged the code as I think ReadDataFromSourceFile should encapsulate opening and closing the csv file as well as reading data from it (only an opinion)
Sub ImportLMSFiles()
Dim fd As FileDialog
Dim FileChosen As Long
Dim FileName As String
Dim i As Long
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "Libraries\Documents"
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
For i = 1 To fd.SelectedItems.Count
Call ReadDataFromSourceFile(fd.SelectedItems(i))
Next i
End If
End Sub
Private Sub ReadDataFromSourceFile(sSrcFilename As String)
' Validate the name
If Right(sSrcFilename, 4) <> ".csv" Then Exit Sub
Application.ScreenUpdating = False
Dim shtDest As Worksheet: Set shtDest = ThisWorkbook.Sheets.Add
Dim wbSrc As Workbook: Set wbSrc = Workbooks.Open(sSrcFilename)
' csv files have only 1 sheet
' UsedRange is exactly what it sounds like
With wbSrc.Sheets(1)
.UsedRange.Copy shtDest.Range(.UsedRange.Address)
' if you want to rename the new sheet
' Bug: another sheet might have the same name -> u need check for that
' Here I'm just ducking it: name not changed
On Error Resume Next
shtDest.Name = .Name
On Error GoTo 0
End With
wbSrc.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
I have many xlsx and xls files in a folder containing 2-3 worksheets in each file. I want to merge all these files into one workbook. I have a sample code but it is not merging xlsx file, it is picking only xls files of the selected folder. Sample code is mentioned below. Help me
Sub MergeFiles ()
Dim numberOfFilesChosen, i As Integer
Dim tempFD As FileDialog
Dim mainWb, sourceWb As Workbook
Dim tempWS As Worksheet
Set mainWb = Workbooks.Add 'Application.ActiveWorkbook
Set tempFD = Application.FileDialog(msoFileDialogFilePicker)
'Allow the user to select multiple workbooks
tempFD.AllowMultiSelect = True
numberOfFilesChosen = tempFD.Show
'Loop through all selected workbooks
For i = 1 To tempFD.SelectedItems.Count
'Open each workbook
Workbooks.Open tempFD.SelectedItems(i)
Set sourceWb = ActiveWorkbook
'Copy each worksheet to the end of the main workbook
For Each tempWS In sourceWb.Worksheets
tempWS.Copy after:=mainWb.Sheets(mainWb.Worksheets.Count)
Next tempWS
'Close the source workbook
sourceWb.Close
Next i
End Sub
Your code does work without any problems with a small amount of xls, xlsx and xlsb files.
I've tried with 24 different files.
Sub MergeFiles()
Application.ScreenUpdating = False ' **** Gain some performance?
Dim numberOfFilesChosen, i As Integer
Dim tempFD As FileDialog
Dim mainWb, sourceWb As Workbook
Dim tempWS As Worksheet
Set mainWb = Workbooks.Add 'Application.ActiveWorkbook
Set tempFD = Application.FileDialog(msoFileDialogFilePicker)
'Allow the user to select multiple workbooks
tempFD.AllowMultiSelect = True
numberOfFilesChosen = tempFD.Show
'Loop through all selected workbooks
For i = 1 To tempFD.SelectedItems.Count
'Open each workbook
Workbooks.Open tempFD.SelectedItems(i)
Set sourceWb = ActiveWorkbook
' Application.ScreenUpdating = True '****** Uncomment to get more feedback
' mainWb.Activate
' mainWb.Sheets(1).Range("A1").EntireRow.Insert
' mainWb.Sheets(1).Range("A1").Value = sourceWb.Name
' Debug.Print sourceWb.Name
' Application.ScreenUpdating = True
'Copy each worksheet to the end of the main workbook
For Each tempWS In sourceWb.Worksheets
tempWS.Copy after:=mainWb.Sheets(mainWb.Worksheets.Count)
Next tempWS
'Close the source workbook
sourceWb.Close
Next i
Application.ScreenUpdating = True ' **** Gain some performance?
End Sub
I wrote a code that is opening a window in which I can select a the excel workbook (#2) I want to copy and import the worksheet from.
The Code is then checking whether the wanted worksheet (named "Guidance") exists in the opened workbook (#2).If so it should be copied and pasted into the current workbook (#1).
After pasting the worksheet the workbook (#2) should be closed again.
So far the code does what I want it to do, as it opens the window and lets me select the wanted worksheet (named "Guidance") but I have the bug (not sure if the translation is correct)
"Runtime error '9': index out of range"
where the worksheet is supposed to be copied and pasted.
Any help on that would be very much appreciated! Thanks in advance.
Private Function SheetExists(sWSName As String, Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then
Set InWorkbook = ThisWorkbook
End If
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
On Error GoTo 0
End Function
Sub GuidanceImportieren()
Dim sImportFile As String, sFile As String
Dim sThisWB As Workbook
Dim vFilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisWB = ActiveWorkbook
sImportFile = Application.GetOpenFilename("Microsoft Excel Workbooks,
*xls; *xlsx; *xlsm")
If sImportFile = "False" Then
MsgBox ("No File Selected")
Exit Sub
Else
vFilename = Split(sImportFile, "|")
sFile = vFilename(UBound(vFilename))
Application.Workbooks.Open (sImportFile)
Set wbWB = Workbooks("sImportFile")
With wbWB
If SheetExists("Guidance") Then
Set wsSht = .Sheets("Guidance")
wsSht.Copy Before:=sThisWB.Sheets("Guidance")
Else
MsgBox ("No worksheet named Guidance")
End If
wbWB.Close SaveChanges:=False
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The issue is here
Set wbWB = Worksheets("Guidance") '<-- this should be a workbook not a worksheet?
With wbWB '<-- this with is useless until …
If SheetExists("Guidance") Then
Set wsSht = .Sheets("Guidance") '<-- … until Sheets here starts with a dot
wsSht.Copy Before:=sThisWB.Sheets("Guidance") 'if the error is here then there is no sheet "Guidance" in sThisWB
Else
MsgBox ("No worksheet named Guidance")
End If
wbWB.Close SaveChanges:=False
End With
Also note that SheetExists("Guidance") does not check in a specific workbook (which may fail). I recommend to extend the function to:
Private Function SheetExists(WorksheetName As String, Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then
Set InWorkbook = ThisWorkbook 'fallback if not set
End If
Dim ws As Worksheet
On Error Resume Next
Set ws = InWorkbook.Worksheets(WorksheetName)
SheetExists = Not ws Is Nothing
On Error Goto 0 'necessary because the Err.Number will not be cleared on End Function
End Function
So you can test if a worksheet exists in a specific workbook like
SheetExists("Guidance", sThisWB)
SheetExists("Guidance", wbWB)
Sub GuidanceImportieren()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sImportFile As String
sImportFile = Application.GetOpenFilename("Microsoft Excel Workbooks, *xls; *xlsx; *xlsm")
If sImportFile = False Then 'false should not be "false"
MsgBox "No File Selected"
Exit Sub
Else
Dim vFilename As Variant
vFilename = Split(sImportFile, "|")
Dim sFile As String
sFile = vFilename(UBound(vFilename))
Dim ImportWorkbook As Workbook
Set ImportWorkbook = Application.Workbooks.Open(sImportFile)
If SheetExists("Guidance", ImportWorkbook) Then
ImportWorkbook.Sheets("Guidance").Copy Before:=ThisWorkbook.Sheets("Guidance")
'you might need to change it into something like this:
Else
MsgBox "No worksheet named Guidance"
End If
ImportWorkbook.Close SaveChanges:=False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I do have a problem activating a workbook in the middle of a VBA code:
The idea is to Open New file->User enters a new name for that file (mainWB)->Rename the file->Choose other xlsx files from a folder -> for each file selected:
open file
select and copy all data from the first sheet
open mainWB
create a new sheet
paste data copied
rename sheet with AF2.value
close all files selected previously.
So far I have:
Sub OpenSelectedFiles()
Dim fd As FileDialog
Dim SelectedFile As Integer
Dim FileName As String
Dim TempWB As Workbook
Dim MainWB As Workbook
Dim i As Integer
Dim oldName As String
Dim newName As String
oldName = ActiveWorkbook.FullName
newName = Application.InputBox(Prompt:="Nombre del Nuevo Archivo:")
ActiveWorkbook.SaveAs newName
newName=ActiveWorkbook.Name
Kill oldName
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "Libraries\Documents"
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
SelectedFile = fd.Show
If SelectedFile = -1 Then
For i = 1 To fd.SelectedItems.Count
Set TempWB = Workbooks.Open(fd.SelectedItems(i))
Call CopyFromOpenFile(TempWB)
Next i
End If
Dim openWB As Workbook
Application.ScreenUpdating = False
For Each openWB In Application.Workbooks
If Not (openWB Is Application.ActiveWorkbook) Then
openWB.Close
End If
Next
Application.ScreenUpdating = True
End Sub
Private Sub CopyFromOpenFile(src As Workbook)
Application.ScreenUpdating = False
Cells.Select
Selection.Copy
Windows(newName).Activate 'Here Excel gives me an error, I cannot activate it to paste the data from the other files
Sheets.Add After:=ActiveSheet
Cells.Select
ActiveSheet.Paste
ActiveSheet.Name = Range("AF2").Value
End Sub
End Sub
If someone has an ideia on how to solve it i'll appreciate a lot.
Thanks in advance!
I want to copy columns (A, C, D, Q:T) in one sheet and paste them to another.
When I paste column B also pastes to the other sheet. I didn't select B.
Here is my code:
Private Sub cmdselectfile_Click()
Dim Filepath As Variant
Dim ws As Worksheet
Dim wb As Workbook
Filepath = Application.GetOpenFilename(FileFilter:="Excel Files, *.xls, All files (*.*), *.*", Title:="Please select a file...")
If VarType(Filepath) = vbString And Filepath <> Empty Then
Set wb = Workbooks.Open(Filepath) 'active file
Union(Columns("A:A"), Columns("C:D"), Columns("Q:T")).Select
Selection.Copy
wb.Close
With ThisWorkbook
Set ws = ThisWorkbook.Worksheets("data")
ws.Columns("A:G").PasteSpecial
End With
Exit Sub
Else
MsgBox "Incorrect Input, Please select the file again"
Exit Sub
End If
End Sub
Hi try this code...
Private Sub cmdselectfile_Click()
Dim Filepath As Variant
Dim ws As Worksheet
Dim wb As Workbook
Filepath = Application.GetOpenFilename(FileFilter:="Excel Files, *.xls, All files (*.*), *.*", Title:="Please select a file...")
If VarType(Filepath) = vbString And Filepath <> Empty Then
Set wb = Workbooks.Open(Filepath) 'active file
Union(Range("A1").EntireColumn, Range("C1:D1").EntireColumn, Range("Q1:T1").EntireColumn).Copy Destination:=ThisWorkbook.Sheets("data").Range("A1")
wb.Close
Exit Sub
Else
MsgBox "Incorrect Input, Please select the file again"
Exit Sub
End If
End Sub