从基于可变用户定义path的封闭工作簿中复制数据
我已经耗尽了我的searchfunction，寻找解决scheme。 以下是我想要做的事情的概要：
- 用户打开启用macros的Excel文件
- 即时提示显示用户input或select所需工作簿的文件path。 他们将需要select两个文件，文件名可能不一致
- input文件位置后，第一个文件select中的第一个工作表将被复制到已启用macros的工作簿的第一个工作表中，第二个文件select的第一个工作表将被复制到已启用macros的工作簿的第二个工作表。
我遇到了一些对ADO的引用，但是我对此还不太了解。
编辑：我已经find一个代码来从一个封闭的文件中导入数据。 我将需要调整范围来返回variables的结果。
Private Function GetValue(path, file, sheet, ref) path = "C:\Users\crathbun\Desktop" file = "test.xlsx" sheet = "Sheet1" ref = "A1:R30" ' Retrieves a value from a closed workbook Dim arg As String ' Make sure the file exists If Right(path, 1) <> "\" Then path = path & "\" If Dir(path & file) = "" Then GetValue = "File Not Found" Exit Function End If ' Create the argument arg = "'" & path & "[" & file & "]" & sheet & "'!" & _ Range(ref).Range("A1").Address(, , xlR1C1) ' Execute an XLM macro GetValue = ExecuteExcel4Macro(arg) End Function Sub TestGetValue() path = "C:\Users\crathbun\Desktop" file = "test" sheet = "Sheet1" Application.ScreenUpdating = False For r = 1 To 30 For C = 1 To 18 a = Cells(r, C).Address Cells(r, C) = GetValue(path, file, sheet, a) Next C Next r Application.ScreenUpdating = True End Sub 现在，我需要一个命令button或用户窗体，它将立即提示用户定义文件path，并从该文件导入数据。
我不介意在过程中打开这些文件。 我只是不希望用户必须单独打开文件。 我只需要他们能够select或导航到所需的文件
这是一个基本的代码。 此代码要求用户select两个文件，然后将相关工作表导入当前工作簿。 我有两个select。 把你的select:)
尝试和testing
选项1（直接导入表格，而不是复制到表格1和2中）
Option Explicit Sub Sample() Dim wb1 As Workbook, wb2 As Workbook Dim Ret1, Ret2 Set wb1 = ActiveWorkbook '~~> Get the first File Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _ , "Please select first file") If Ret1 = False Then Exit Sub '~~> Get the 2nd File Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _ , "Please select Second file") If Ret2 = False Then Exit Sub Set wb2 = Workbooks.Open(Ret1) wb2.Sheets(1).Copy Before:=wb1.Sheets(1) ActiveSheet.Name = "Blah Blah 1" wb2.Close SaveChanges:=False Set wb2 = Workbooks.Open(Ret2) wb2.Sheets(1).Copy After:=wb1.Sheets(1) ActiveSheet.Name = "Blah Blah 2" wb2.Close SaveChanges:=False Set wb2 = Nothing Set wb1 = Nothing End Sub
选项2（将表格内容导入到工作表1和2中）
Option Explicit Sub Sample() Dim wb1 As Workbook, wb2 As Workbook Dim Ret1, Ret2 Set wb1 = ActiveWorkbook '~~> Get the first File Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _ , "Please select first file") If Ret1 = False Then Exit Sub '~~> Get the 2nd File Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _ , "Please select Second file") If Ret2 = False Then Exit Sub Set wb2 = Workbooks.Open(Ret1) wb2.Sheets(1).Cells.Copy wb1.Sheets(1).Cells wb2.Close SaveChanges:=False Set wb2 = Workbooks.Open(Ret2) wb2.Sheets(1).Cells.Copy wb1.Sheets(2).Cells wb2.Close SaveChanges:=False Set wb2 = Nothing Set wb1 = Nothing End Sub
下面的函数从closures的Excel文件中读取数据并将结果返回到数组中。 它失去了格式化，公式等。你可能想调用你的主代码中的isArrayEmpty函数（在底部）来testing函数返回的东西。
Public Function getDataFromClosedExcelFile(parExcelFileName As String, parSheetName As String) As Variant 'see http://www.ozgrid.com/forum/showthread.php?t=19559 'returns an array (1 to nRows, 1 to nCols) which should be tested with isArrayEmpty in the calling function Dim locConnection As New ADODB.Connection Dim locRst As New ADODB.Recordset Dim locConnectionString As String Dim locQuery As String Dim locCols As Variant Dim locResult As Variant Dim i As Long Dim j As Long On Error GoTo error_handler locConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _ & "Data Source=" & parExcelFileName & ";" _ & "Extended Properties=""Excel 8.0;HDR=YES"";" locQuery = "SELECT * FROM [" & parSheetName & "$]" locConnection.Open ConnectionString:=locConnectionString locRst.Open Source:=locQuery, ActiveConnection:=locConnection If locRst.EOF Then 'Empty sheet or only one row ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''' FIX: an empty sheet returns "F1" '''''' http://support.microsoft.com/kb/318373 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" Then Exit Function 'Empty sheet ReDim locResult(1 To 1, 1 To locRst.Fields.Count) As Variant For i = 1 To locRst.Fields.Count locResult(1, i) = locRst.Fields(i - 1).Name Next i Else locCols = locRst.GetRows ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''' FIX: an empty sheet returns "F1" '''''' http://support.microsoft.com/kb/318373 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" And UBound(locCols, 2) = 0 And locCols(0, 0) = "" Then Exit Function 'Empty sheet ReDim locResult(1 To UBound(locCols, 2) + 2, 1 To UBound(locCols, 1) + 1) As Variant If locRst.Fields.Count <> UBound(locCols, 1) + 1 Then Exit Function 'Not supposed to happen For j = 1 To UBound(locResult, 2) locResult(1, j) = locRst.Fields(j - 1).Name Next j For i = 2 To UBound(locResult, 1) For j = 1 To UBound(locResult, 2) locResult(i, j) = locCols(j - 1, i - 2) Next j Next i End If locRst.Close locConnection.Close Set locRst = Nothing Set locConnection = Nothing getDataFromClosedExcelFile = locResult Exit Function error_handler: 'Wrong file name, sheet name, or other errors... 'Errors (#N/A, etc) on the sheet should be replaced by Null but should not raise an error If locRst.State = ADODB.adStateOpen Then locRst.Close If locConnection.State = ADODB.adStateOpen Then locConnection.Close Set locRst = Nothing Set locConnection = Nothing End Function Public Function isArrayEmpty(parArray As Variant) As Boolean 'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase) If IsArray(parArray) = False Then isArrayEmpty = True On Error Resume Next If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False End Function
样品使用：
Sub test() Dim data As Variant data = getDataFromClosedExcelFile("myFile.xls", "Sheet1") If Not isArrayEmpty(data) Then 'Copies content on active sheet ActiveSheet.Cells(1,1).Resize(UBound(data,1), UBound(data,2)) = data End If End Sub