excel vba如何将其他许多excel文件中的其中一条数据放到一个excel表格中

求代码

推荐答案 2016-03-10

如果其他的Excel文件都在同一个目录中，

加个模块，复制下面的代码：

'****************************************************************
'功能：    查找指定文件夹含子文件夹内所有文件名（含路径）
'函数名：  FileAllArr
'参数1：   Filename    需查找的文件夹名不含最后的"\"
'参数2：   FileFilter  需要过滤的文件名，可省略，默认为：[*.*]
'参数3：   Liwai       剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
'返回值：  一个字符型的数组
'使用方法：arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name)

Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "") As String()
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add (Filename & "\"), ""
    i = 0
    Do While i < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(i), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(i) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        i = i + 1
    Loop

i = 0
Dim arrx() As String
    For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
        MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
        Do While MyFileName <> ""
           If MyFileName <> Liwai Then '排除例外文件
              ReDim Preserve arrx(i)
              arrx(i) = Ke & MyFileName
              i = i + 1
           End If
            MyFileName = Dir
        Loop
    Next
    FileAllArr = arrx
End Function
'****************************************************************

可以在 Sheet1的代码中写

Sub OPIONA() '//函数实例
    Dim sP As String, WB As Workbook
    sP = "E:\VB合并同规格Excel\tmp"  '很多Excel文件的路径，不含最后的\
    arr = FileAllArr(sP, "*.xls", ThisWorkbook.Name)
    Application.ScreenUpdating = False
    For i = 0 To UBound(arr)
        'MsgBox arr(I)
        Set WB = Workbooks.Open(arr(i))
        '你的代码
        ThisWorkbook.Worksheets(1).Cells(i + 1, 1).Value = WB.Worksheets(1).Range("T1000").End(xlUp).Value
        WB.Windows(1).Visible = False
        WB.Close False
    Next
    Application.ScreenUpdating = True
End Sub

以上文件路径需要自己更改，主要取数的代码解释如下：

ThisWorkbook.Worksheets(1).Cells(i + 1, 1).Value = WB.Worksheets(1).Range("T1000").End(xlUp).Value

从打开文件的T列最后一个数值取值赋值给操作表的Sheet1中的单元格。

如果数据在每一个Excel中的位置是固定的，比如T10，代码可以直接改为：

ThisWorkbook.Worksheets(1).Cells(i + 1, 1).Value = WB.Worksheets(1).Range("T10").Value

追问

我能qq具体问您吗？

追答

公司不让上，发邮件吧[email protected]

追问

好的

已发，谢谢