批量对同意文件夹下面的相同格式的xls文件提取数据再保存到其他文件夹

下是一种

    现有很多很多个格式一样（行数多少有区别）xls文件，需要提取里面特定的某些列的数据到新的xls文件内，并保存到特定的文件夹内，如何实现啊？    附件也有详细说明。

    谢谢老师们！

LangQueS

基础数据应该保存在同一个工作表中，以便管理。

关于使用Excel管理数据的基本方法请参考：
  
★Excel数据管理的一般规律★    http://club.excelhome.net/thread-287461-1-1.html

zhaogang1960

ADO法请参考：

1. Sub ADO法()
   
2.     Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, n&, t$, a, arr, aField(2), i&, j&, f$, p$
   
3.     arr = Array("1、2、3、4、25、26、27、28、29、30、31", "1、2、3、4、33", "1、2、3、4、46")
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set cnn = CreateObject("ADODB.Connection")
   
6.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.     For Each File In Fso.GetFolder(p).Files
   
8.         If File.Name Like "*.xls" And File.Name <> ThisWorkbook.Name Then
   
9.             n = n + 1
   
10.             If n = 1 Then
    
11.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & File
    
12.                 Set rs = cnn.Execute("[Sheet1$]")
    
13.                 For i = 0 To 2
    
14.                     a = Split(arr(i), "、")
    
15.                     For j = 0 To UBound(a)
    
16.                         aField(i) = aField(i) & "," & rs.Fields(a(j) * 1 - 1).Name
    
17.                     Next
    
18.                 Next
    
19.             Else
    
20.                 t = "[Excel 8.0;Database=" & File & "]."
    
21.             End If
    
22.             For i = 1 To 3
    
23.                 f = p & i & "" & File.Name
    
24.                 If Fso.FileExists(f) Then Fso.DeleteFile f
    
25.                 SQL = "Select " & Mid(aField(i - 1), 2) & " into [Excel 8.0;Database=" & f & ";].Sheet1 from " & t & "[Sheet1$]"
    
26.                 cnn.Execute SQL
    
27.             Next
    
28.         End If
    
29.     Next
    
30.     MsgBox "ok"
    
31.     rs.Close
    
32.     cnn.Close
    
33.     Set rs = Nothing
    
34.     Set cnn = Nothing
    
35. End Sub
    

复制代码

zhaogang1960

请测试附件
谢谢您.rar (76.6 KB, 下载次数: 99)

2015-1-31 00:02 上传

点击文件名下载附件

chenbiao2012

1. Sub test()
   
2.     Application.DisplayAlerts = False
   
3.     Application.ScreenUpdating = False
   
4.     crr = Array(Array(1, 2, 3, 4, 25, 26, 27, 28, 29, 30, 31), Array(1, 2, 3, 4, 33), Array(1, 2, 3, 4, 46))
   
5.     mypath = ThisWorkbook.Path & ""
   
6.     myname = Dir(mypath & "*.xls")
   
7.     Do While myname <> "" And myname <> ThisWorkbook.Name
   
8.             Set wb = GetObject(mypath & myname)
   
9.             arr = wb.Sheets("sheet1").UsedRange
   
10.             For k = 0 To 2
    
11.                 ReDim brr(1 To UBound(arr), 1 To UBound(crr(k)) + 1)
    
12.                 For i = 1 To UBound(arr)
    
13.                     For j = 1 To UBound(crr(k)) + 1
    
14.                         brr(i, j) = arr(i, crr(k)(j - 1))
    
15.                     Next
    
16.                 Next
    
17.                 Set wk = Workbooks.Add
    
18.                 With wk
    
19.                     .Sheets("sheet1").[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
    
20.                     .SaveAs mypath & k + 1 & "" & k & myname
    
21.                     .Close False
    
22.                 End With
    
23.             Next
    
24.             wb.Close False
    
25.             myname = Dir
    
26.             Set wb = Nothing
    
27.     Loop
    
28.     Application.DisplayAlerts = True
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    
31. 
    

复制代码

chenbiao2012

在同文件夹下新建一个book1.xls，然后把代码copy 运行即可

LMY123

SQL多工作薄，批量提取不同列，另存为工作薄