Sub过程导入它的子表

我得到这个代码工作了一段时间，但最近几天没有工作。 从活动workbook1它假设导入表Thisworkbook2：

Sub ImportallWBsh() 'https://michaelaustinfu.files.wordpress.com/2013/03/excel-vba-for-dummies-3rd-edition.pdf, Page 245 Dim Finfo As String Dim FilterIndex As Integer Dim Title As String Dim Filename As Variant Dim wb As Workbook 'Setup the list of file filters Finfo = "Excel Files (*.xlsx),*xlsx," 'Display *.* by default FilterIndex = 1 'Set the dialog box caption Title = "Select a File to Import" 'Get the Filename Filename = Application.GetOpenFilename(Finfo, _ FilterIndex, Title) 'Handle return info from dialog box If Filename = False Then MsgBox "No file was selected." Else MsgBox "You selected " & Filename End If On Error Resume Next Set wb = Workbooks.Open(Filename) FilenameWorkbook.Sheets.Copy _ After:=ThisWorkbook.Sheets("Sheet3") wb.Close True ThisWorkbook.Sheets("Sheet1").Select End Sub 

你知道这可能是错的吗？ 谢谢

Answer 1

你有几个问题正在进行中…

您正在使用Set不正确。 GetOpenFileName返回一个string。 Workbooks.Open返回一个对象。 看看这个 。 你的第一部分可以阅读：

 s = Application.GetOpenFilename() Set Wb1 = Workbooks.Open (s) 

你也打开了两次工作簿，再加上你创build的对象objexcel创build了一个新的Excel实例，但是你不用Set objexcel = Nothingclosures它，所以每次运行代码时，都会有另一个副本Excel在后台打开。

（closuresExcel，然后CTRL + ALT + DEL检查您的任务pipe理器，我打赌你会明白我的意思！）

首先，我build议你尝试一下这个search ， 这个search会显示一些针对同样问题的解决scheme，例如这个和这个 。

Answer 2

像这样的东西应该为你做的工作。

 Sub Basic_Example_1() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, Fnum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long 'Fill in the path\folder where the files are MyPath = "C:\Users\Ron\test" 'Add a slash at the end if the user forget it If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If 'If there are no Excel files in the folder exit the sub FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If 'Fill the array(myFiles)with the list of Excel files in the folder Fnum = 0 Do While FilesInPath <> "" Fnum = Fnum + 1 ReDim Preserve MyFiles(1 To Fnum) MyFiles(Fnum) = FilesInPath FilesInPath = Dir() Loop 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'Add a new workbook with one sheet Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 'Loop through all files in the array(myFiles) If Fnum > 0 Then For Fnum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next With mybook.Worksheets(1) Set sourceRange = .Range("A1:C1") End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else 'if SourceRange use all columns then skip this file If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet" BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else 'Copy the file name in column A With sourceRange BaseWks.cells(rnum, "A"). _ Resize(.Rows.Count).Value = MyFiles(Fnum) End With 'Set the destrange Set destrange = BaseWks.Range("B" & rnum) 'we copy the values from the sourceRange to the destrange With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next Fnum BaseWks.Columns.AutoFit End If ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub 

https://www.rondebruin.nl/win/s3/win008.htm

Answer 3

正确的行代码需要是：

 ActiveWorkbook.Sheets.Copy _ After:=ThisWorkbook.Sheets("Hoja3") 

所以代码正常工作。 谢谢