求助 帮忙解答代码 提取数据到当前表格

wewes

如何提取其他表格数据到当前表格了，别人给我一个代码，但是运行不成功啊？不知道怎么回事？

zxsea_7426

简单修改，能用，但会复制很多空格

wewes

zxsea_7426 发表于 2023-6-5 21:18
简单修改，能用，但会复制很多空格

代码附件能传一下吗

zxsea_7426

1. Sub on1_Click()
   
2. 
   
3.     Dim MyPath As String, FilesInPath As String
   
4.     Dim MyFiles() As String
   
5.     Dim SourceR As String
   
6.     Dim wb As Workbook
   
7.     Dim DestR As Range
   
8.     Dim i As Integer, j As Integer
   
9.    
   
10.     '设置源数据范围
    
11.     SourceR = Range("A1:B60").Address
    
12.    
    
13.     '设置目标数据范围
    
14.     Set DestR = ActiveSheet.Range("A1")
    
15.    
    
16.     '获取当前文件夹路径
    
17.     MyPath = ActiveWorkbook.Path & ""
    
18.    
    
19.     '获取当前文件夹下的所有 Excel 文件
    
20.     FilesInPath = Dir(MyPath & "*.xls*")
    
21.     i = 0
    
22.    
    
23.     '循环处理每个 Excel 文件
    
24.     Do While FilesInPath <> "" And FilesInPath <> ThisWorkbook.Name
    
25.         If FilesInPath <> ThisWorkbook.Name Then
    
26.             i = i + 1
    
27.             ReDim Preserve MyFiles(1 To i)
    
28.             MyFiles(i) = FilesInPath
    
29.             FilesInPath = Dir()
    
30.         End If
    
31.     Loop
    
32.    
    
33.     '循环打开每个 Excel 文件，复制数据到目标工作薄
    
34.     For j = 1 To UBound(MyFiles)
    
35.         Application.ScreenUpdating = False
    
36.         Set wb = Workbooks.Open(MyPath & MyFiles(j), 0)
    
37.         wb.Sheets(1).Range(SourceR).Copy
    
38.         DestR.Offset((j - 1) * 60, 0).PasteSpecial xlPasteValues
    
39.         Application.CutCopyMode = False
    
40.         wb.Close , False
    
41.     Next j
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "数据已复制完成。"
    
44. End Sub

复制代码