复制多个excel表格中指定列到一个新的Excel表格中

姚学升

问题：有100多个结果一样的excel文件，每个excel都只有一个工作表，我需要从这100多个excel表格中复制指定1列，依次排列到新的Excel表格中，有多少个Excel表格，那么新的表格中就有多少列。比如，我需要复制100个Excel表格中的I列，在新的excel表格中依次排列这100列。

姚学升

我目前的做法就是苯方法，用单元格引用，在新的Excel表格中做好了100列公式，等收集好了100个excel表格，到时候打开新的Excel表，这样每个单元格读取

姚学升

D:\桌面\合并\1\[1 (1).xlsx]测试'!$I2，就这样每个单元格读取

fzxba

1. Sub test1()
   
2.   Dim Conn As Object, strConn As String
   
3.   Dim p As String, f As String, s As String, c As Integer
   
4.   
   
5.   ActiveSheet.UsedRange.ClearContents
   
6.   Application.ScreenUpdating = False
   
7.   
   
8.   s = "Excel 12.0;HDR=yes;Database="
   
9.   If Application.Version < 12 Then
   
10.     s = Replace(s, "12.0", "8.0")
    
11.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
12.   Else
    
13.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
14.   End If
    
15.   
    
16.   Set Conn = CreateObject("ADODB.Connection")
    
17.   Conn.Open strConn & ThisWorkbook.FullName
    
18.   
    
19.   p = "D:\桌面\合并\1\"
    
20.   f = Dir(p & "*.xls?")
    
21.   
    
22.   While Len(f)
    
23.     If p & f <> ThisWorkbook.FullName Then
    
24.       c = c + 1
    
25.       Cells(1, c) = Split(f, ".xls")(0)
    
26.       Cells(2, c).CopyFromRecordset Conn.Execute("SELECT * FROM [" & s & p & f & "].[$I1:I]")
    
27.     End If
    
28.     f = Dir
    
29.   Wend
    
30. 
    
31.   Conn.Close
    
32.   Set Conn = Nothing
    
33.   
    
34.   Application.ScreenUpdating = True
    
35.   Beep
    
36. End Sub

复制代码

高个子

看着需要VBA解决，不会就去VBA版块问

姚学升

fzxba 发表于 2023-1-5 18:03

感谢回复，我运行没有反映，我的是excel2019

姚学升

fzxba 发表于 2023-1-5 18:03

也没有错误显示，就是没有反映

fzxba

姚学升 发表于 2023-1-7 21:26
也没有错误显示，就是没有反映

检查一下第19行的路径。还有，无附件不再回复。

姚学升

fzxba 发表于 2023-1-7 21:33
检查一下第19行的路径。还有，无附件不再回复。

路径没有错误