简体   繁体   中英

Excel VBA Copy a Workbook to another one with Dialog

I am a beginner in Excel VBA programming and am tasked to develop a Tool in Excel for monitoring. I do have knowledge in other Languages like Java, C++ and Python, therefore I know how to do the Logic, but VBA is a difficult one.

The Thing: What I need to get working is the following: I have a Workbook, lets call it Tool.xlsm in which I've wrote the sorting and filtering logic. This part is working fine. It uses a seperate sheet in that workbook for the "background data". This sheet is what this is about.

I want to write a macro which displays a file selection dialouge. The selected file then gets copied to a new sheet in my Workbook. The file is a .xls table with 3 sheets. The data needed is in sheet 1.

Public Sub copyData()
Set appxl = CreateObject("Excel.application")
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String

sourceFileName = "FileToCopy.xlsx"

'Open Source File.xlsx
With appxl
.Workbooks.Open ActiveWorkbook.Path & "\" & sourceFileName
.Visible = False
End With    

'Get first sheet data
Set myfile = appxl.Windows(sourceFileName)
myfile.Activate
Set currentSheet = appxl.Sheets(1)

'Past the table in my current Excel file
lastRow = currentSheet.Range("A1").End(xlDown).Row
Sheets("Data retrieval").Range("A1:Y" & lastRow) = currentSheet.Range("A1:Y"& lastRow).Value

'Close Source File.xlsx
appxl.Workbooks(sourceFileName).Close
End Sub

This is the Code I wrote with the help of the famous GoogleSearch.

Now to the Specific Questions:

  1. How do I code a FileSelectionDialouge?
  2. how do I fix the error 9, outofBounds?

Ive searched in Stackoverflow for quite some time, but didnt find a similar problem. This is my first Post here, I apologize for any mistakes made. Also I apologize for any grammar or vocabular mistakes, english is not my native language :)

Many thanks for reading.

Ninsa

Edit: Ive modified the code according to the answers below. It now looks like this:

Public Sub copyData2()
Set appxl = CreateObject("Excel.application")
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String

'Ask the user to select a file
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .ButtonName = "Import File"
    .InitialView = msoFileDialogViewSmallIcons
    .Title = "Please Select File"
    If .Show = -1 Then Collation_File = .SelectedItems(1)
End With


sourceFileName = Collation_File

'Open Source File.xlsx
With appxl
    .Workbooks.Open Collation_File
    .Visible = False
End With

'Get first sheet data
Set myfile = appxl.Windows(sourceFileName)
myfile.Activate
Set currentSheet = Workbooks("sourceFileName").Sheets(1)

'Past the table in my current Excel file
lastRow = currentSheet.Range("A1").End(xlDown).Row
Debug.Print lastRow
Sheets("test").Range("A1:Y" & lastRow) = currentSheet.Range("A1:Y" & lastRow).Value

'Close Source File.xlsx
appxl.Workbooks(sourceFileName).Close
End Sub

For the first part you could use the following function based on this article in MSDN

Function GetFileName() As String

    GetFileName = ""
    ' Open the file dialog
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        If .Show = -1 Then
            GetFileName = .SelectedItems(1)
        End If
    End With

End Function

Update I re-wrote your code to

Public Sub copyData()
    Dim sourceWkb As Workbook
    Dim sourceWks As Worksheet
    Dim targetWks As Worksheet
    Dim sourceFilename As String
    Dim lastRow As Long

    Set targetWks = Sheets("Data retrieval")

    sourceFilename = GetFileName
    Set sourceWkb = Workbooks.Open(sourceFilename)
    Set sourceWks = sourceWkb.Sheets(1)


    'Past the table in my current Excel file
    lastRow = sourceWks.Range("A1").End(xlDown).Row
    targetWks.Range("A1:Y" & lastRow) = sourceWks.Range("A1:Y" & lastRow).Value

    'Close Source File.xlsx
    sourceWkb.Close False
End Sub

With Application.ScreenUpdating = False you can turn off screen flickering.

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM