怎样将CSV的众多系统文件汇总到一个Excel工作表中

lnzcqlx

Sub aaasf()
Dim a As Integer, b As Integer
a = 1
b = 8
Range(Cells(a + 1, 1), Cells(65536, b)).ClearContents
Application.ScreenUpdating = False
Dim c As String, d As Integer, e As Workbook, f As Worksheet, g As Variant, h As String
c = Dir(ThisWorkbook.Path & "\*.csv")
Do While c <> ""
    If c <> ThisWorkbook.Name Then
        d = [a1].CurrentRegion.Rows.Count - 1
        h = ThisWorkbook.Path & "\" & c
        Set e = GetObject(h)
        Set f = e.Sheet1
        g = f.Range(f.Cells(a + 1, 1), f.Cells(65536, b).End(xlUp))
        Cells(d, 1).Resize(UBound(g, 1), UBound(g, 2)) = g
        e.Close False
    End If
    c = Dir
Loop
Application.ScreenUpdating = True
End Sub
这个是针对excel表的，但是用csv的时候就不行了    请大神指点

lnzcqlx

帮帮忙啊！

zhaogang1960

使用复制法吧:

1. Sub aaasf()
   
2. Application.ScreenUpdating = False
   
3. Dim c As String, d As Integer, e As Workbook, f As Worksheet, g As Variant, h As String, m As Integer
   
4. Cells.ClearContents
   
5. Set f = ActiveSheet
   
6. c = Dir(ThisWorkbook.Path & "\*.csv")
   
7. Do While c <> ""
   
8.     If c <> ThisWorkbook.Name Then
   
9.         m = m + 1
   
10.         h = ThisWorkbook.Path & "" & c
    
11.         Set e = GetObject(h)
    
12.         If m = 1 Then
    
13.             e.Sheets(1).UsedRange.Copy f.[a1]
    
14.         Else
    
15.             e.Sheets(1).UsedRange.Offset(1).Copy f.[a65536].End(xlUp).Offset(1)
    
16.         End If
    
17.         e.Close False
    
18.     End If
    
19.     c = Dir
    
20. Loop
    
21. Application.ScreenUpdating = True
    
22. End Sub
    

复制代码

zhaogang1960

请看附件
各机构汇总.rar (14.54 KB, 下载次数: 30)

2013-11-19 16:19 上传

点击文件名下载附件

lnzcqlx

谢谢 大哥

zhaogang1960

如果csv文件不超过49个，可用ADO联合查询方法，速度比打开复制快很多：

1. Sub ADO读取csv文件()
   
2.     Dim cnn As Object, rs As Object, SQL$, myPath$, MyFile$, i&
   
3.     myPath = ThisWorkbook.Path & ""
   
4.     Set cnn = CreateObject("adodb.connection")
   
5.     cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='text;FMT=DELIMITED';Data Source=" & myPath
   
6.     MyFile = Dir(myPath & "*.csv")
   
7.     Application.ScreenUpdating = False
   
8.     ActiveSheet.UsedRange.ClearContents
   
9.     Do While MyFile <> ""
   
10.         If Len(SQL) Then SQL = SQL & " union all "
    
11.         SQL = SQL & "select * from [" & MyFile & "]"
    
12.         MyFile = Dir()
    
13.     Loop
    
14.     Set rs = cnn.Execute(SQL)
    
15.     For i = 1 To rs.Fields.Count
    
16.         Cells(1, i) = rs.Fields(i - 1).Name
    
17.     Next
    
18.     [a2].CopyFromRecordset rs
    
19.     cnn.Close
    
20.     Set cnn = Nothing
    
21.     Application.ScreenUpdating = True
    
22. End Sub
    

复制代码

zhaogang1960

请看附件
汇总模板ADO.rar (13.3 KB, 下载次数: 46)

2013-11-19 16:40 上传

点击文件名下载附件

Hcy1993

zhaogang1960 发表于 2013-11-19 16:19
请看附件

老师  ，请问下，我用您这个代码，发现如果行数太多的话，会出现错误，请问要怎么解决

LMY123

Hcy1993 发表于 2018-9-28 11:26
老师  ，请问下，我用您这个代码，发现如果行数太多的话，会出现错误，请问要怎么解决

上传附件，分析一下