求：一个目录下面的xls文件批量进行删除第一行数量另存为txt是如何操作的。

mfkpie8

一个目录下面的xls文件批量进行删除第一行数量另存为txt是如何操作的。谢谢高手 。。

Sub Macro1()
    Dim cnn As Object, rs As Object, SQL$, MyFile$, s$
    MyFile = Dir(ThisWorkbook.Path & "\*.xls")
    While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            Set cnn = CreateObject("adodb.connection")
            cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='excel 8.0;hdr=no';Data Source=" & ThisWorkbook.Path & "\" & MyFile
            Set rs = cnn.OpenSchema(20)
            Do Until rs.EOF
                    Rows("1:1").Select
                                Selection.Delete Shift:=xlUp
                rs.MoveNext
            Loop
        End If
        MyFile = Dir()
    Wend
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub



这个有错误的。

guanmy

1。目录循环XLS文件
2。对每一个循环XLS文件OPEN 删除第一行
3。对XLS文件取数据保存txt文件。

zhaogang1960

这个代码好像是我写的，ADO调用工作表数据时，并没有传统上的打开概念，所有不能使用下面操作工作表的语句
Rows("1:1").Select
Selection.Delete Shift:=xlUp
可使用其他方式导出文本文件

请上传附件，说明导出文本文件样式等

zhaogang1960

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, rst As Object, SQL$
   
3.     Dim MyFile$, s$, t$, i&, j&, p$
   
4.     p = ThisWorkbook.Path & ""
   
5.     MyFile = Dir(p & "*.xls")
   
6.     While MyFile <> ""
   
7.         If MyFile <> ThisWorkbook.Name Then
   
8.             Set cnn = CreateObject("adodb.connection")
   
9.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=excel 8.0;Data Source=" & ThisWorkbook.Path & "" & MyFile
   
10.             Set rs = cnn.OpenSchema(20)
    
11.             Do Until rs.EOF
    
12.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
13.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
14.                     If Right(s, 1) = "$" Then
    
15.                         SQL = "select * from [" & s & "]"
    
16.                         Set rst = CreateObject("adodb.Recordset")
    
17.                         rst.Open SQL, cnn, 1, 3
    
18.                         Open p & Replace(MyFile, ".xls", ".txt") For Output As #1
    
19.                         For i = 1 To rst.RecordCount
    
20.                             t = ""
    
21.                             For j = 0 To rst.Fields.Count - 1
    
22.                                 t = t & Chr(9) & rst.Fields(j).Value
    
23.                             Next j
    
24.                             Print #1, Mid(t, 2)
    
25.                             rst.MoveNext
    
26.                         Next i
    
27.                         Close #1
    
28.                     End If
    
29.                 End If
    
30.                 rs.MoveNext
    
31.             Loop
    
32.         End If
    
33.         MyFile = Dir()
    
34.     Wend
    
35.     rs.Close
    
36.     rst.Close
    
37.     cnn.Close
    
38.     Set rs = Nothing
    
39.     Set rst = Nothing
    
40.     Set cnn = Nothing
    
41. End Sub
    

复制代码

zhaogang1960

代码要求每个工作簿只有一个工作表，且数据规范(见下面附件)
adotext.rar (22.1 KB, 下载次数: 95)

2012-11-6 16:45 上传

点击文件名下载附件

mfkpie8

zhaogang1960 发表于 2012-11-6 16:45
代码要求每个工作簿只有一个工作表，且数据规范(见下面附件)

恩谢谢非常的好今天一天就完成了。开始学习excel好强大哦