VBA 从一堆EXCEL表里提取固定单元格的数据。

发布网友 发布时间：2022-04-24 02:53

我来回答

共2个回答

热心网友 时间：2023-10-23 03:47

'从楼上的改一下，使用集合提高效率，其他优化。
Sub MeThee()
Application.ScreenUpdating = False
     Dim aFileName$,myPath$
     Dim aCollection As New Collection
     Dim bCollection As New Collection
     myPath = "d:\xxx\"  '设置路径
     aFileName = Dir(myPath & "*.xls*")   '从myPath指定的目录查找excel文件     
     While aFileName <> "" And Instr(1,aFileName,"$") = 0 Then
        With Workbooks.Open(Filename:=myPath & aFileName, ReadOnly:=True)   '以只读方式打开工作簿
            aCollection.Add .Sheets1.Range("B5")    '假如姓名在B5
            bCollection.Add .Sheets1.Range("F5")    '假如姓名在B5
            .Close False   '关闭工作簿
        End With         
        f = Dir    '查找下一个
     Wend
Application.ScreenUpdating = True
End Sub

热心网友 时间：2023-10-23 03:47

Sub a()
On Error Resume Next
     Dim wb As Workbook
     Dim f As String, r As Long
     Dim path As String
     path = "d:\xxx\"
     r = 2 '从第二行开始写数据
     f = Dir(path & "*.xls*")   '从path指定的目录查找excel文件
    
     While f <> ""
        Set wb = Workbooks.Open(Filename:=path & f, ReadOnly:=True)   '以只读方式打开工作簿
        If Not Err Then
            Sheet1.Cells(r, 1) = wb.Sheets(1).Range("B5") '假如姓名在B5
            Sheet1.Cells(r, 2) = wb.Sheets(1).Range("F5") '假如生日在F5
            r = r + 1
            
            wb.Close False   '关闭工作簿
        End If
        
        f = Dir    '查找下一个
     Wend
End Sub

热心网友 时间：2023-10-23 03:47

'从楼上的改一下，使用集合提高效率，其他优化。
Sub MeThee()
Application.ScreenUpdating = False
     Dim aFileName$,myPath$
     Dim aCollection As New Collection
     Dim bCollection As New Collection
     myPath = "d:\xxx\"  '设置路径
     aFileName = Dir(myPath & "*.xls*")   '从myPath指定的目录查找excel文件     
     While aFileName <> "" And Instr(1,aFileName,"$") = 0 Then
        With Workbooks.Open(Filename:=myPath & aFileName, ReadOnly:=True)   '以只读方式打开工作簿
            aCollection.Add .Sheets1.Range("B5")    '假如姓名在B5
            bCollection.Add .Sheets1.Range("F5")    '假如姓名在B5
            .Close False   '关闭工作簿
        End With         
        f = Dir    '查找下一个
     Wend
Application.ScreenUpdating = True
End Sub

热心网友 时间：2023-10-23 03:47

Sub a()
On Error Resume Next
     Dim wb As Workbook
     Dim f As String, r As Long
     Dim path As String
     path = "d:\xxx\"
     r = 2 '从第二行开始写数据
     f = Dir(path & "*.xls*")   '从path指定的目录查找excel文件
    
     While f <> ""
        Set wb = Workbooks.Open(Filename:=path & f, ReadOnly:=True)   '以只读方式打开工作簿
        If Not Err Then
            Sheet1.Cells(r, 1) = wb.Sheets(1).Range("B5") '假如姓名在B5
            Sheet1.Cells(r, 2) = wb.Sheets(1).Range("F5") '假如生日在F5
            r = r + 1
            
            wb.Close False   '关闭工作簿
        End If
        
        f = Dir    '查找下一个
     Wend
End Sub

热心网友 时间：2023-10-23 03:47

'从楼上的改一下，使用集合提高效率，其他优化。
Sub MeThee()
Application.ScreenUpdating = False
     Dim aFileName$,myPath$
     Dim aCollection As New Collection
     Dim bCollection As New Collection
     myPath = "d:\xxx\"  '设置路径
     aFileName = Dir(myPath & "*.xls*")   '从myPath指定的目录查找excel文件     
     While aFileName <> "" And Instr(1,aFileName,"$") = 0 Then
        With Workbooks.Open(Filename:=myPath & aFileName, ReadOnly:=True)   '以只读方式打开工作簿
            aCollection.Add .Sheets1.Range("B5")    '假如姓名在B5
            bCollection.Add .Sheets1.Range("F5")    '假如姓名在B5
            .Close False   '关闭工作簿
        End With         
        f = Dir    '查找下一个
     Wend
Application.ScreenUpdating = True
End Sub

热心网友 时间：2023-10-23 03:47

Sub a()
On Error Resume Next
     Dim wb As Workbook
     Dim f As String, r As Long
     Dim path As String
     path = "d:\xxx\"
     r = 2 '从第二行开始写数据
     f = Dir(path & "*.xls*")   '从path指定的目录查找excel文件
    
     While f <> ""
        Set wb = Workbooks.Open(Filename:=path & f, ReadOnly:=True)   '以只读方式打开工作簿
        If Not Err Then
            Sheet1.Cells(r, 1) = wb.Sheets(1).Range("B5") '假如姓名在B5
            Sheet1.Cells(r, 2) = wb.Sheets(1).Range("F5") '假如生日在F5
            r = r + 1
            
            wb.Close False   '关闭工作簿
        End If
        
        f = Dir    '查找下一个
     Wend
End Sub