通过select文件从多个Excel文件自动复制一系列数据

我试图build立一个macros，通过select我想要复制的Excel文件，从一个单元格范围内的多个文件自动复制一些数据。 我目前做了一些东西，但远远不是太高效，因为我必须每次在特定path中保存文件，或者有时手动复制一个工作簿中的单元格区域。 我想select工作簿并能够保存在现有工作簿上，因为标题可以有一些引用，有时文件具有受保护的VBA项目。 我下面的代码是从第一个工作表中复制一行，并从指定文件夹中打开的文件复制第二个工作表中的一系列单元格，然后将这些单元格保存到代码所在的文件中。 

Sub LoopThroughDirectory() On Error Resume Next Dim MyFile As String Dim erow Dim erowc Dim Filepath As String Filepath = "C:\Users\noStress\Desktop\Workbook test\Destinatia mea\" MyFile = Dir(Filepath) Dim Matrice() As Variant Dim Dim1, Dim2 As Long Application.ScreenUpdating = False Application.DisplayAlerts = False Do While Len(MyFile) > 0 If MyFile = "Transport_data.xlsm" Then Exit Sub End If Workbooks.Open (Filepath & MyFile) Worksheets(1).Activate Range("A2:M2").Copy Worksheets(2).Activate Dim1 = Range("A2", Range("A1").End(xlDown)).Cells.Count - 1 Dim2 = Range("A1", Range("A1").End(xlToRight)).Cells.Count - 1 ReDim Matrice(0 To Dim1, 0 To Dim2) For Dim1 = LBound(Matrice, 1) To UBound(Matrice, 1) For Dim2 = LBound(Matrice, 2) To UBound(Matrice, 2) Matrice(Dim1, Dim2) = Range("A2").Offset(Dim1, Dim2).Value Next Dim2 Next Dim1 ActiveWorkbook.Close Worksheets(2).Activate erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice Worksheets(1).Activate erow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row ActiveSheet.Paste Destination:=Worksheets(1).Range(Cells(erow, 1), Cells(erow, 14)) MyFile = Dir Loop End Sub

对你的代码的评论

Application.DisplayAlerts = False意味着用户不会看到任何警报。 我认为这是危险的。 我这样使用这个语句： 

 Application.DisplayAlerts = False Delete worksheet Application.DisplayAlerts = True

也就是说，我closures单个语句的警报。 如果适当的话，我已经与用户检查过了，删除工作表是可以的。 

 If MyFile = "Transport_data.xlsm" Then Exit Sub End If

我假设Transport_data.xlsm是包含macros的工作簿。 通常情况下，Dir按创build的顺序返回文件，所以在Transport_data.xlsm之后创build的任何文件都不会被处理。 你想要的东西像： 

 If MyFile <> "Transport_data.xlsm" Then Process file End If

值得注意的是， ThisWorkbook.Name给出了持有正在运行的macros的工作簿的名称。 因此，如果更改工作簿的名称，以下方法仍然有效： 

 If MyFile <> ThisWorkbook.Name Then Process file End If

Worksheets(N)是Tab中的第N个工作表。 如果用户更改工作表的顺序，工作表编号会更改，您可能无法获得您所期望的工作表。

始终按名称标识工作表： Worksheets("xxxxx")

Worksheets(N)Activate缓慢，应该避免。

在下面，激活Worksheets(2)然后在下面的语句中完全限定您想要的工作表： 

 Worksheets(2).Activate erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

你不需要Activate

你用 

 `ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice`

下载到目标范围，但从源范围逐个单元Matrice载Matrice 。 你可以用同样的方法加载Matrice 。 

 Dim Matrice As Variant Matrice = SourceRange.Value ' This will size Matrice as required DestinationRange.Value = Matrice

您的要求

您想从多个工作簿中提取数据，而不是全部存储在同一个文件夹中。 您认为（希望）您需要的工作表是第一个工作表。 你的macros拷贝整个工作表，但是你的文本意味着你想更有select性。 既然你想自动化这个过程，我认为这是一个间隔重复的过程。

我可能会得出结论，但这听起来像是我的一个客户的要求。 他们从他们的来源收到多个工作簿，但他们只需要select的信息的pipe理摘要。 他们手动执行整合，这是耗时且容易出错的。 如果你的需求是他们的需求，你不希望用户select文件; 您希望过程完全自动化。 我不再有我为该客户端创build的代码，但我已经从内存创build了一个简单的版本。

我已经创build了一个名为“说明”的工作表的工作簿。 他们有多个这样的工作表，因为他们有几个合并。 但是，足以表明原则。 工作表有多行。 每行指定从一个工作簿到另一个工作簿的范围的复制。 这些列是： 

 Source Folder range Workbook name Worksheet name Left column \ Top row | Source range Right column | Bottom row / Destination Folder range Workbook name Worksheet name Top left destination cell

这是我的testing数据的图像：

我的测试说明

注意：这个数据是为了testingmacros而devise的; 这不是一套特别明智的指示。

在我为客户端创build的系统和我为您创build的简单macros中，Folder是一个固定的string。 例如：“C：\ Users \ noStress \ Desktop \ Workbook test \ Destinatia mea”或“C：\ Users \ ajdal \ Desktop \ Workbooks \ CopyRanges”。 文件夹名称必须在第一个指令行中指定。 只需要在后续行上指定它，如果它改变。

在我为您创build的macros中，工作簿名称是固定的。 例如：“A.xlsx”或“B.xlsx”。 在我的客户端系统中，它是一个模板，例如：“Branch A * .xlsx”。 macros将从与该模板匹配的文件夹中select最新的文件。

在这两个系统中，工作表名称是固定的。

注意：如果指定了新文件夹，则需要新的工作簿名称和新的工作表名称。 如果指定了新的工作簿名称，则需要新的工作表名称。

在Left，Top，Rght和Bot中总是需要数值。 序列被select，所以它看起来像一个范围。 将这些作为单独的列（而不是例如“A1：D8”）的优点在于，允许诸如“Last”的单词容易地使得“A | 1 | Last | Last”指定整个工作表和“A | Last | Last | Last”整个最后一行。 下面的macros中没有包含这个function。

目标文件夹，工作簿和工作表的规则与源代码相同。

目的地只需要左上angular的单元格。 我已经包含代码以允许“D”或“A”作为从前一个副本或从前一个副本的下一个目的地。

如果指令行中的某个值缺失或错误，则该单元格将被着色为Rose，并且该行将被忽略。 macros继续下一行，所以尽可能多的指令可以一次testing。 例如：

错误的测试说明彩色玫瑰

macros可能有太多的validation，没有足够的testing。 对于客户，非技术人员创build了指令工作表。 如果他们拼错工作簿或工作表名称，macros不能停止工作簿打开或工作表访问所以一切都validation。 我已经包括validation，但没有testing每个可能的用户错误。 我总是通过我的macros在每个path的顶部包含Debug.Assert False 。 在testing期间，一个path被执行，我注释掉Debug.Assert False 。 任何在testing结束时未注释的内容都表明我的testing不足，或者我的devise有问题，无法达到目的。 这里的指示错误条件我还没有testing过。

注意：我用SourceRange.Copy Destination:=TopLeftCell来复制数据。 这具有复制格式的优点，但具有公式也被复制的缺点。 如果这是不可接受的，通过Variant数组复制可能会更好。

如果这个function听起来很有意思，那就和macros一起玩吧。 

 Option Explicit Const ClrError As Long = 13408767 ' Rose = RGB(255, 153, 204) Const ClrSrc As Long = 10092543 ' Light yellow = RGB(255, 255, 153) Const ClrDest As Long = 16777164 ' Light turquoise - RGB(204, 255, 255) Const ColInstSrcFld As Long = 1 Const ColInstSrcWbk As Long = 2 Const ColInstSrcWsht As Long = 3 Const ColInstSrcColLeft As Long = 4 Const ColInstSrcRowTop As Long = 5 Const ColInstSrcColRight As Long = 6 Const ColInstSrcRowBot As Long = 7 Const ColInstDestFld As Long = 8 Const ColInstDestWbk As Long = 9 Const ColInstDestWsht As Long = 10 Const ColInstDestRng As Long = 11 Const ColsSrc As String = "A:G" ' \ Used for colouring columns Const ColsDest As String = "H:K" ' / Sub CopyRanges() Dim ColDest As Long Dim ColSrcLeft As Long Dim ColSrcRight As Long Dim DestFldStr As String Dim DestWbkStr As String Dim DestWbkChanged As Boolean Dim DestWshtStr As String Dim DestRngStr As String Dim ErrorOnRow As Boolean Dim NumColsRngSrc As Long Dim NumRowsRngSrc As Long Dim RngDest As Range Dim RngSrc As Range Dim RowDest As Long Dim RowInstCrnt As Long Dim RowInstLast As Long Dim RowSrcBot As Long Dim RowSrcTop As Long Dim SrcFldStr As String Dim SrcWbkStr As String Dim SrcWshtStr As String Dim WbkDest As Workbook Dim WbkSrc As Workbook Dim WshtDest As Worksheet Dim WshtInst As Worksheet Dim WshtSrc As Worksheet ' Note the initial values for variables are: ' 0 for Long ' "" for String ' Nothing for Object (for example: workbook, worksheet, range) Application.ScreenUpdating = False Set WshtInst = Worksheets("Instructions") With WshtInst ' Restore background colour of source and destination columns ' to clear and error recorded by last run. .Columns(ColsSrc).Interior.Color = ClrSrc .Columns(ColsDest).Interior.Color = ClrDest ' Find last row of instructions RowInstLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row End With For RowInstCrnt = 3 To RowInstLast With WshtInst ErrorOnRow = False ' Validate source columns of instructions If .Cells(RowInstCrnt, ColInstSrcFld).Value <> "" Then ' New source folder; must be new workbook and worksheet 'Debug.Assert False If .Cells(RowInstCrnt, ColInstSrcWbk).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcWbk).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If If .Cells(RowInstCrnt, ColInstSrcWsht).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If ElseIf .Cells(RowInstCrnt, ColInstSrcWbk).Value <> "" Then ' New source workbook; must be new worksheet 'Debug.Assert False If .Cells(RowInstCrnt, ColInstSrcWsht).Value = "" Then 'Debug.Assert False .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If ' Source range must always be specified in full ' Top row must be non-empty, numeric and a valid row number If .Cells(RowInstCrnt, ColInstSrcRowTop).Value = "" Then 'Debug.Assert False .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True ElseIf Not IsNumeric(.Cells(RowInstCrnt, ColInstSrcRowTop).Value) Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True Else RowSrcTop = .Cells(RowInstCrnt, ColInstSrcRowTop).Value If RowSrcTop < 1 Or RowSrcTop > Rows.Count Then .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If ' Left column must be non-empty and a valid column code If .Cells(RowInstCrnt, ColInstSrcColLeft).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcColLeft).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True Else ColSrcLeft = ColNum(.Cells(RowInstCrnt, ColInstSrcColLeft).Value) If ColSrcLeft = 0 Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcColLeft).Interior.Color = ClrError ' Record faulty value End If End If ' Bottom row must be non-empty, numeric and a valid row number greater or equal to top row If .Cells(RowInstCrnt, ColInstSrcRowBot).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcRowBot).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True ElseIf Not IsNumeric(.Cells(RowInstCrnt, ColInstSrcRowBot).Value) Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcRowBot).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True Else RowSrcBot = .Cells(RowInstCrnt, ColInstSrcRowBot).Value If RowSrcBot < 1 Or RowSrcBot > Rows.Count Or RowSrcTop > RowSrcBot Then .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If ' right column must be non-empty and a valid column code greater or equal to left column If .Cells(RowInstCrnt, ColInstSrcColRight).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcColRight).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True Else ColSrcRight = ColNum(.Cells(RowInstCrnt, ColInstSrcColRight).Value) If ColSrcRight = 0 Or ColSrcLeft > ColSrcRight Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcColRight).Interior.Color = ClrError ' Record faulty value End If End If ' If no error in source columns, load new values from instruction row to variables. ' Check have value for every parameter. Check folder and workbook exist if specified ' Close old workbook if appropriate. Open new workbook if appropriate If Not ErrorOnRow Then 'Debug.Assert False If .Cells(RowInstCrnt, ColInstSrcFld).Value <> "" Then ' New source folder 'Debug.Assert False SrcFldStr = .Cells(RowInstCrnt, ColInstSrcFld).Value If Right$(SrcFldStr, 1) <> "\" Then 'Debug.Assert False SrcFldStr = SrcFldStr & "\" End If If Not PathExists(SrcFldStr) Then Debug.Assert False .Cells(RowInstCrnt, ColInstSrcFld).Interior.Color = ClrError ' Record faulty value SrcFldStr = "" ErrorOnRow = True End If ElseIf SrcFldStr = "" Then ' No source folder specified Debug.Assert False .Cells(RowInstCrnt, ColInstSrcFld).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If If Not ErrorOnRow Then 'Debug.Assert False If .Cells(RowInstCrnt, ColInstSrcWbk).Value <> "" Then ' New source workbook; close old one if any 'Debug.Assert False If Not WbkSrc Is Nothing Then 'Debug.Assert False WbkSrc.Close SaveChanges:=False Set WbkSrc = Nothing End If SrcWbkStr = .Cells(RowInstCrnt, ColInstSrcWbk).Value If FileExists(SrcFldStr, SrcWbkStr) Then 'Debug.Assert False Set WbkSrc = Workbooks.Open(FileName:=SrcFldStr & SrcWbkStr, _ UpdateLinks:=True, ReadOnly:=True) Else 'Debug.Assert False .Cells(RowInstCrnt, ColInstSrcWbk).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If End If If Not ErrorOnRow Then 'Debug.Assert False If .Cells(RowInstCrnt, ColInstSrcWsht).Value <> "" Then 'Debug.Assert False SrcWshtStr = .Cells(RowInstCrnt, ColInstSrcWsht).Value If WshtExists(WbkSrc, SrcWshtStr) Then 'Debug.Assert False Set WshtSrc = WbkSrc.Worksheets(SrcWshtStr) Else 'Debug.Assert False .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If End If If Not ErrorOnRow Then 'Debug.Assert False Set RngSrc = WshtSrc.Range(WshtSrc.Cells(RowSrcTop, ColSrcLeft), _ WshtSrc.Cells(RowSrcBot, ColSrcRight)) End If ' Validate destination columns of instructions. If .Cells(RowInstCrnt, ColInstDestFld).Value <> "" Then ' New destination folder; must be new workbook, worksheet and range 'Debug.Assert False If .Cells(RowInstCrnt, ColInstDestWbk).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If If .Cells(RowInstCrnt, ColInstDestWsht).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If ElseIf .Cells(RowInstCrnt, ColInstDestWbk).Value <> "" Then ' New destination workbook; must be new worksheet and range 'Debug.Assert False If .Cells(RowInstCrnt, ColInstDestWsht).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then Debug.Assert False .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then ' Destination range must always be specified Debug.Assert False .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If ' If no error in destination columns, load new values from instruction row to variables. ' Check have value for every parameter. Check folder and workbook exist if specified ' Close old workbook if appropriate. Open new workbook if appropriate If Not ErrorOnRow Then 'Debug.Assert False If .Cells(RowInstCrnt, ColInstDestFld).Value <> "" Then ' New destination folder 'Debug.Assert False DestFldStr = .Cells(RowInstCrnt, ColInstDestFld).Value If Right$(DestFldStr, 1) <> "\" Then DestFldStr = DestFldStr & "\" End If If Not PathExists(DestFldStr) Then Debug.Assert False .Cells(RowInstCrnt, ColInstDestFld).Interior.Color = ClrError ' Record faulty value DestFldStr = "" ErrorOnRow = True End If ElseIf DestFldStr = "" Then ' No destination folder specified Debug.Assert False .Cells(RowInstCrnt, ColInstDestFld).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If If Not ErrorOnRow Then 'Debug.Assert False If .Cells(RowInstCrnt, ColInstDestWbk).Value <> "" Then ' New destination workbook; close old one if any 'Debug.Assert False If Not WbkDest Is Nothing Then 'Debug.Assert False If DestWbkChanged Then 'Debug.Assert False WbkDest.Close SaveChanges:=True DestWbkChanged = False Else Debug.Assert False WbkDest.Close SaveChanges:=False End If Set WbkDest = Nothing End If DestWbkStr = .Cells(RowInstCrnt, ColInstDestWbk).Value If FileExists(DestFldStr, DestWbkStr) Then 'Debug.Assert False Set WbkDest = Workbooks.Open(FileName:=DestFldStr & DestWbkStr, _ UpdateLinks:=True, ReadOnly:=False) DestWbkChanged = False Else 'Debug.Assert False .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If Else ' No new workbook. Check one remains open from previous instructions If WbkDest Is Nothing Then 'Debug.Assert False .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If End If If Not ErrorOnRow Then 'Debug.Assert False If .Cells(RowInstCrnt, ColInstDestWsht).Value <> "" Then 'Debug.Assert False DestWshtStr = .Cells(RowInstCrnt, ColInstDestWsht).Value If WshtExists(WbkDest, DestWshtStr) Then 'Debug.Assert False Set WshtDest = WbkDest.Worksheets(DestWshtStr) ' Clear source range and destination cell information saved from ' previous instruction row and used in processing "destination cells" ' A(cross) and D(own). RowDest = 0 ColDest = 0 NumRowsRngSrc = 0 NumColsRngSrc = 0 Else Debug.Assert False .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True End If End If End If If Not ErrorOnRow Then 'Debug.Assert False Select Case UCase(.Cells(RowInstCrnt, ColInstDestRng).Value) Case "D" ' Down from previous transfer ' Should have RowDest, ColDest, NumRowsRngSrc and NumColsRngSrc from ' last instruction row 'Debug.Assert False If RowDest = 0 Or ColDest = 0 Or NumRowsRngSrc = 0 Or NumColsRngSrc = 0 Then ' No appropriate previous instruction row Debug.Assert False .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True Else 'Debug.Assert False ' Calculate new row from information saved from last ' error-free instruction row. Column unchanged. RowDest = RowDest + NumRowsRngSrc End If Case "A" ' Across from previous transfer ' Should have RowDest, ColDest, NumRowsRngSrc and NumColsRngSrc from ' last instruction row 'Debug.Assert False If RowDest = 0 Or ColDest = 0 Or NumRowsRngSrc = 0 Or NumColsRngSrc = 0 Then ' No appropriate previous instruction row Debug.Assert False .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True Else 'Debug.Assert False ' Calculate new column from information saved from last ' error-free instruction row. Row unchanged ColDest = ColDest + NumColsRngSrc End If Case Else 'Debug.Assert False DestRngStr = .Cells(RowInstCrnt, ColInstDestRng).Value Err.Clear On Error Resume Next Set RngDest = WshtDest.Range(DestRngStr) On Error GoTo 0 If Err <> 0 Then Debug.Assert False ' Faulty range .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError ' Record faulty value ErrorOnRow = True Else ' Convert destination to numbers 'Debug.Assert False ColDest = RngDest.Column RowDest = RngDest.Row End If End Select End If End With ' WshtInst If Not ErrorOnRow Then ' All parameters stored ready for actioning RngSrc.Copy Destination:=WshtDest.Cells(RowDest, ColDest) DestWbkChanged = True ' Extract number of rows and columns from source range in case next ' instruction has "destination cell" as A(cross) or D(own) NumRowsRngSrc = RngSrc.Rows.Count NumColsRngSrc = RngSrc.Columns.Count End If Next If Not WbkSrc Is Nothing Then 'Debug.Assert False WbkSrc.Close SaveChanges:=False Set WbkSrc = Nothing End If If Not WbkDest Is Nothing Then Debug.Assert False If DestWbkChanged Then Debug.Assert False WbkSrc.Close SaveChanges:=True Else Debug.Assert False WbkSrc.Close SaveChanges:=False End If Set WbkDest = Nothing End If End Sub Public Function ColNum(ByVal ColCode As String) As Long ' Checks ColCode is a valid column code for the version of Excel in use ' If it is, it returns the equivalent column number. ' If it is not, it returns 0. ' Coded by Tony Dallimore Dim ChrCrnt As String Dim ColCodeUc As String: ColCodeUc = UCase(ColCode) Dim Pos As Long ColNum = 0 For Pos = 1 To Len(ColCodeUc) ChrCrnt = Mid(ColCodeUc, Pos, 1) If ChrCrnt < "A" Or ChrCrnt > "Z" Then ColNum = 0 Exit Function End If ColNum = ColNum * 26 + Asc(ChrCrnt) - 64 Next If ColNum < 1 Or ColNum > Columns.Count Then ColNum = 0 End If End Function Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean ' Returns True if file exists. Assumes path already tested. ' Coded by Tony Dallimore ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283 If Right$(PathName, 1) <> "\" Then PathName = PathName & "\" End If On Error Resume Next FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory) On Error GoTo 0 End Function Public Function PathExists(ByVal PathName As String) As Boolean ' Returns True if path exists ' Coded by Tony Dallimore ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283 On Error Resume Next PathExists = ((GetAttr(PathName) And vbDirectory) = vbDirectory) On Error GoTo 0 End Function Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String) ' Returns True if Worksheet WshtName exists within ' * if Wbk Is Nothing the workbook containing the macros ' * else workbook Wbk ' Coded by Tony Dallimore Dim WbkLocal As Workbook Dim Wsht As Worksheet If Wbk Is Nothing Then Set WbkLocal = ThisWorkbook Else Set WbkLocal = Wbk End If Err.Clear On Error Resume Next Set Wsht = WbkLocal.Worksheets(WshtName) On Error GoTo 0 If Wsht Is Nothing Then WshtExists = False Else WshtExists = True End If End Function

我希望我有这个权利…

你想要：

  • dynamicselect特定文件夹中的文件
  • 将工作表1和工作表2中所选文件的单元格复制到当前工作簿中
  • 保存当前的工作簿？ （我没有完全理解你在这里的意思，所以我把这一部分留下了）

我承担：

  1. 使用ListBox（lstFile，2列）和Commandbutton（cmdCopy）创build一个用户窗体（ufCopy）
  2. 在工作表上创build一个命令button来启动它
  3. 在附加 – >引用中检查“Microsoft Scripting Runtime”，以避免创build对象
  4. 将此代码复制到userforms源代码中

码： 

  Private Sub UserForm_Initialize() Call GetFiles("C:\example\example") 'Enter your folder path here End Sub Private Sub GetFiles(strFile As String) ' 'Populates Listbox with all Excel files in the chosen folder and subfolders ' Dim fso As Scripting.FileSystemObject Dim fsoFolder As Scripting.Folder Dim fsoSubfolder As Scripting.Folder Dim fsoFile As Scripting.File Set fso = New Scripting.FileSystemObject Set fsoFolder = fso.GetFolder(strFile) For Each fsoFile In fsoFolder.Files If Left(fso.GetExtensionName(fsoFile.Path), 2) = "xl" Then With Me.lstFiles .AddItem .List(.ListCount - 1, 0) = fsoFile.Name .List(.ListCount - 1, 1) = fsoFile.Path End With End If Next fsoFile For Each fsoSubfolder In fsoFolder.SubFolders Call GetFiles(fsoSubfolder.Path) Next fsoSubfolder End Sub Private Sub cmdCopy_Click() Dim Msg As String Dim iCounter As Integer Dim wbCur As Workbook Application.ScreenUpdating = False For iCounter = 0 To Me.lstFiles.ListCount - 1 If Me.lstFiles.Selected(iCounter) Then Set wbCur = Workbooks.Open(Me.lstFiles.List(iCounter, 0) & Me.lstFiles.List(iCounter, 1)) ' 'Copy from first sheet ' wbCur.Worksheets(1).Range("A2:M2").Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) ' 'Copy from second sheet ' With wbCur.Worksheets(2) .Range("A1", .Range("A2").End(xlDown).End(xlToRight)).Copy Destination:=ThisWorkbook.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End With wbCur.Close savechanges:=False End If Next iCounter Application.ScreenUpdating = True End Sub

这样做：

  • 在Multiselect列表框中显示所选文件夹和子文件夹的所有Excel文件
  • 循环遍历所有选定的工作簿，并将这些单元复制到这个工作簿

我没有看到该数组的目的，所以我删除了它。 你可以自由地调整代码复制到你的需要。

要启动用户窗体，将其复制到包含命令button的工作表的代码中： 

 Private Sub CommandButton1_Click() ufCopy.Show End Sub

编辑：要dynamicselect您的文件夹path，请使用以下命令： 

 Private Sub UserForm_Initialize() Dim strFolder Dim fdFolder As FileDialog ' Open the file dialog Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker) fdFolder.AllowMultiSelect = False fdFolder.Show strFolder = fdFolder.SelectedItems(1) Call GetFiles(strFolder) End Sub

如果你想从不同的path获取文件，只需将上面的代码添加到你的用户表单上的命令button，而不是intialize。 这样你可以点击它并添加多个目录。

Interesting Posts

用PowerShell读取Excel文件

问题结合Worksheet_Change（无效或不合格的参考错误）

如何使用PowerPivot添加一个计算项目（非字段），同时指向DataModel

VBA：IF条件格式化内部颜色条件不起作用

Excel Addin – 如何在桌面版本中触发文档下载

语法：在excel-vba中使用IF语句

设置单元格的值join

参考运行时在Excel中使用VBA添加的命令button

在函数调用之前或在函数内检查错误？

Excel公式计算差异b / w第一个值和最后一个列的值（Excel）？