批量提取指定工作簿中指定单元格内容到当前工作簿指定位置

xiaobei1988

示例见附件
具体要求如下：
1.数据文件夹下面有若干个工作薄，每个工作簿只有一张工作表。
2.合并工作薄里有两张工作表，一张名为“要求”，一张名为“合并”。
3.“要求”表中的A列为数据文件夹里所有工作簿的文件名称（不含后缀），
   B列为该张表需要提取数据的范围（单元格不连续！！！）
   C列为将该范围数据填充到“合并”表中的位置
4.注：“要求”表中A列中工作簿的文件名称顺序和数据文件夹下的工作簿的文件名称顺序不一致。
5.批量实现。

xiaobei1988

在线等回复

gxhcswj

这个要求写的多代码应该有点多吧

15899681383

Sub merged01()
   
Dim mypath As String
Dim filepath As String
Dim wb As Workbook, rng As Range, rngs As Range
Dim n As Integer, arr, arr1, a
Dim sht As Worksheet, path01 As String

On Error Resume Next
Application.ScreenUpdating = False

Sheets("合并").Cells.ClearContents
Set rngs = ThisWorkbook.Sheets("要求").Range("a2:a11")

   
mypath = ThisWorkbook.Path
   
filepath = Dir(mypath & "\*" & ".xl*")
Debug.Print ThisWorkbook.Name
Do
    If Split(ThisWorkbook.Name, ".")(0) = Split(filepath, ".")(0) Then
        GoTo 100
    Else
        For Each rng In rngs
            If rng.Value = Split(filepath, ".")(0) Then
                arr = Split(rng.Offset(0, 1), ",")
                arr1 = Split(rng.Offset(0, 2), ",")
                    If UBound(arr) <> UBound(arr1) Then
                        MsgBox rng.Address(0, 0) & "旁边B,C列对应位置数量不一致"
                        Exit Sub
                    Else
                    Set wb = Application.Workbooks.Open(mypath & "\" & filepath)
                       For Each sht In wb.Worksheets
                            If wb.Sheets.Count <> 1 Then
                               MsgBox "当前文档超过不等于1个工作表，请修改" & wb.Name
                               wb.Close
                               Exit Sub
                             End If
                        ThisWorkbook.Activate
                        For n = LBound(arr) To UBound(arr)
                            Sheets("合并").Range(arr1(n)) = sht.Range(arr(n)).Value
                        Next
                        Next
                    End If
         
                     wb.Close
                     Exit For
                   End If
        Next
      
      End If

100:
filepath = Dir

Loop Until filepath = ""

MsgBox "合并完成"
   
End Sub

请将合并文件放在一个文件夹里。

xiaobei1988

谢谢老师，太感谢了