选择一个文件夹，遍历其中所有Excel文件，并将每个文件指定的单元格内容拷贝到当前工作簿的目标区域。
Sub 遍历文件拷贝指定区域内容()Dim folderPath As StringDim fileName As StringDim sourceColumns As StringDim targetRow As LongDim wbSource As WorkbookDim wsTarget As WorksheetDim wsSource As WorksheetDim lastRow As LongDim maxLastRow As LongDim sourceRange As RangeDim col As LongDim colStart As LongDim colEnd As Long' 初始化变量targetRow = 1 ' 起始行Set wsTarget = ThisWorkbook.Sheets(1) ' 当前工作簿的第一个工作表' 输入要拷贝的列范围sourceColumns = Application.InputBox("请输入要拷贝的列范围（例如 A:D）：", "指定拷贝列范围", Type:=2)If sourceColumns = "" ThenMsgBox "未输入有效范围", vbExclamationExit SubEnd If' 选择文件夹With Application.FileDialog(msoFileDialogFolderPicker).Title = "选择包含Excel文件的文件夹"If .Show = -1 ThenfolderPath = .SelectedItems(1) & "\"ElseMsgBox "未选择文件夹", vbExclamationExit SubEnd IfEnd With' 遍历文件夹中的所有Excel文件fileName = Dir(folderPath & "*.xls*") ' 支持xls和xlsx格式Do While fileName <> ""' 打开每个Excel文件On Error Resume NextSet wbSource = Workbooks.Open(folderPath & fileName, ReadOnly:=True)If Not wbSource Is Nothing ThenOn Error GoTo 0Set wsSource = wbSource.Sheets(1) ' 默认取第一个工作表' 找到指定列范围的最后一行（所有列中最大的行号）colStart = Columns(Split(sourceColumns, ":")(0)).ColumncolEnd = Columns(Split(sourceColumns, ":")(1)).ColumnmaxLastRow = 0For col = colStart To colEndlastRow = wsSource.Cells(wsSource.Rows.Count, col).End(xlUp).RowIf lastRow > maxLastRow ThenmaxLastRow = lastRowEnd IfNext colIf maxLastRow >= 1 Then' 构建有效的范围Set sourceRange = wsSource.Range(wsSource.Cells(1, colStart), wsSource.Cells(maxLastRow, colEnd))' 拷贝指定范围内容到目标单元格sourceRange.CopywsTarget.Cells(targetRow, 1).PasteSpecial Paste:=xlPasteValuesApplication.CutCopyMode = False ' 取消选中状态' 更新目标行targetRow = targetRow + maxLastRowElseMsgBox "文件：" & fileName & " 中未找到内容", vbExclamationEnd IfwbSource.Close SaveChanges:=FalseElseMsgBox "无法打开文件: " & fileName, vbExclamationEnd IffileName = Dir ' 下一个文件LoopMsgBox "数据导入完成", vbInformation
End Sub
