利用VBA将同文件夹中的excel文件指定区域复制到当前excel中（见附件）

wufan1224

利用VBA将同文件夹中的excel文件指定区域复制到当前excel文件中
有没有高手帮忙做一下，谢谢！

wufan1224

自己顶一个

opel-wong

目标数据表中好错公式的错误值，程序会报错，只能先替换为空值。

opel-wong

上传代码，

1. Sub 提取数据()
   
2.     With Application
   
3.         .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: .AutoFormatAsYouTypeReplaceHyperlinks = False: .AskToUpdateLinks = False
   
4.     End With
   
5.     Dim mFull$, wb As Workbook, arr, AR(), BR(), CR(), DR(), m&, i&
   
6.     mFull = ThisWorkbook.Path & "\WH1810014-C01-00.xls"
   
7.     Set wb = CreateObject(mFull)    ' 打开
   
8.     With wb.Sheets("Sheet1")
   
9.         ' .Cells.SpecialCells(xlCellTypeConstants, 16).ClearContents
   
10.         .Cells.SpecialCells(xlCellTypeFormulas, 16).ClearContents
    
11.         arr = .UsedRange.Value
    
12.     End With
    
13.     wb.Close False
    
14.     ReDim AR(1 To UBound(arr), 1 To 1)
    
15.     ReDim BR(1 To UBound(arr), 1 To 2)
    
16.     ReDim CR(1 To UBound(arr), 1 To 1)
    
17.     ReDim DR(1 To UBound(arr), 1 To 1)
    
18.     For i = 3 To UBound(arr)
    
19.         If arr(i, 5) <> "" Then
    
20.             m = m + 1
    
21.             AR(m, 1) = arr(i, 3)
    
22.             BR(m, 1) = arr(i, 5)
    
23.             BR(m, 2) = arr(i, 6)
    
24.             CR(m, 1) = arr(i, 10)
    
25.             DR(m, 1) = arr(i, 13)
    
26.         End If
    
27.     Next
    
28.     With Worksheets("B号对应表")
    
29.         .Range("A2").Resize(m, 1) = AR
    
30.         .Range("C2").Resize(m, 2) = BR
    
31.         .Range("H2").Resize(m, 1) = CR
    
32.         .Range("K2").Resize(m, 1) = DR
    
33.     End With
    
34.     With Application
    
35.         .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: .AutoFormatAsYouTypeReplaceHyperlinks = True: .AskToUpdateLinks = True
    
36.     End With
    
37. End Sub
    

复制代码

38180203

论坛有的,自己搜索一下,  有一个北极狐大神发过  很好用的