VBA实现遍历Excel文件将指定的单元格内容拷贝到当前工作簿

选择一个文件夹，遍历其中所有Excel文件，并将每个文件指定的单元格内容拷贝到当前工作簿的目标区域。

Sub 遍历文件拷贝指定区域内容()


    Dim folderPath As String
    Dim fileName As String
    Dim sourceColumns As String
    Dim targetRow As Long
    Dim wbSource As Workbook
    Dim wsTarget As Worksheet
    Dim wsSource As Worksheet
    Dim lastRow As Long
    Dim maxLastRow As Long
    Dim sourceRange As Range
    Dim col As Long
    Dim colStart As Long
    Dim colEnd As Long
    
    ' 初始化变量
    targetRow = 1 ' 起始行
    Set wsTarget = ThisWorkbook.Sheets(1) ' 当前工作簿的第一个工作表
    
    ' 输入要拷贝的列范围
    sourceColumns = Application.InputBox("请输入要拷贝的列范围（例如 A:D）：", "指定拷贝列范围", Type:=2)
    If sourceColumns = "" Then
        MsgBox "未输入有效范围", vbExclamation
        Exit Sub
    End If
    
    ' 选择文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择包含Excel文件的文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "未选择文件夹", vbExclamation
            Exit Sub
        End If
    End With
    
    ' 遍历文件夹中的所有Excel文件
    fileName = Dir(folderPath & "*.xls*") ' 支持xls和xlsx格式
    Do While fileName <> ""
        ' 打开每个Excel文件
        On Error Resume Next
        Set wbSource = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
        If Not wbSource Is Nothing Then
            On Error GoTo 0
            Set wsSource = wbSource.Sheets(1) ' 默认取第一个工作表
            
            ' 找到指定列范围的最后一行（所有列中最大的行号）
            colStart = Columns(Split(sourceColumns, ":")(0)).Column
            colEnd = Columns(Split(sourceColumns, ":")(1)).Column
            maxLastRow = 0
            
            For col = colStart To colEnd
                lastRow = wsSource.Cells(wsSource.Rows.Count, col).End(xlUp).Row
                If lastRow > maxLastRow Then
                    maxLastRow = lastRow
                End If
            Next col
            
            If maxLastRow >= 1 Then
                ' 构建有效的范围
                Set sourceRange = wsSource.Range(wsSource.Cells(1, colStart), wsSource.Cells(maxLastRow, colEnd))
                
                ' 拷贝指定范围内容到目标单元格
                sourceRange.Copy
                wsTarget.Cells(targetRow, 1).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False ' 取消选中状态
                
                ' 更新目标行
                targetRow = targetRow + maxLastRow
            Else
                MsgBox "文件：" & fileName & " 中未找到内容", vbExclamation
            End If
            
            wbSource.Close SaveChanges:=False
        Else
            MsgBox "无法打开文件: " & fileName, vbExclamation
        End If
        fileName = Dir ' 下一个文件
    Loop
    
    MsgBox "数据导入完成", vbInformation
End Sub