关于批量导入txt文本的问题

chxw68

程序还有点小BUG，我又修改了一下。

张雄友

chxw68 发表于 2013-11-22 22:01
没看清！把28-31和41这三行语句删掉。

太强大了。

1. 
   
2. '引用Microsoft Scripting Runtime
   
3. '引用“Microsoft Active Data Objects 2.8 Library"
   
4. Sub 导入()
   
5.   Dim fso As New FileSystemObject
   
6.   Dim ws As Worksheet
   
7.   
   
8.   If MsgBox("提取数据将删除本工作簿除[总表]以外的其他数据表并重新生成，确定提取吗？", vbOKCancel + vbQuestion + vbDefaultButton2, "提示") = vbCancel Then
   
9.     Exit Sub
   
10.   End If
    
11.   
    
12.   Dim mybook As String
    
13.   Dim mysheet As String
    
14.   Application.DisplayAlerts = False
    
15.   Application.ScreenUpdating = False
    
16.   
    
17.   For Each ws In Worksheets
    
18.     If ws.Name <> ActiveSheet.Name Then
    
19.       ws.Delete
    
20.     End If
    
21.   Next
    
22.   Set f = fso.GetFolder(ThisWorkbook.Path)
    
23.   For Each wj In f.Files
    
24.     If wj.Name Like "*.txt" Then
    
25.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
26.       ws.Name = Left(wj.Name, Len(wj.Name) - 4)
    
27.       Set f1 = fso.OpenTextFile(ThisWorkbook.Path & "" & wj.Name, ForReading, False)
    
28.       i = 1
    
29.       m = 1
    
30.       Do While f1.AtEndOfStream <> True
    
31.         'If i = 2 Then
    
32.           's = Split(f1.ReadLine, ",")
    
33.           'bm = s(1)
    
34.         'Else
    
35.           s = Split(f1.ReadLine, ",")
    
36.           For j = 0 To UBound(s)
    
37.             If j = 0 Then
    
38.               ws.Cells(m, j + 1) = "'" & s(j)
    
39.             Else
    
40.               ws.Cells(m, j + 1) = s(j)
    
41.             End If
    
42.           Next
    
43.           m = m + 1
    
44.         'End If
    
45.         i = i + 1
    
46.       Loop
    
47.       f1.Close
    
48.       Columns(1).Insert
    
49.       Range("a1").Resize(Range("b1").End(xlDown).Row, 1) = bm
    
50.     End If
    
51.   Next
    
52.   Columns(1).Delete '用完后去掉多余列
    
53.   With ActiveSheet
    
54.   .Cells.EntireColumn.AutoFit '自动适应列宽
    
55.   .Cells.EntireRow.AutoFit '自动适应行高
    
56.   End With
    
57.   Application.DisplayAlerts = True
    
58.   Application.ScreenUpdating = True
    
59.   Set fso = Nothing
    
60. End Sub
    

复制代码

lipton

解决第一列的数字格式问题，使用Schema.ini文件

子程序：

1. Public Sub CreateSchemaFile(sPath As String, sSectionName As String)
   
2.     '创建SchemaFile.ini文件
   
3.          Dim Handle As Integer
   
4. 
   
5.          Handle = FreeFile
   
6.          Open sPath & "schema.ini" For Output Access Write As #Handle
   
7. 
   
8.         Print #Handle, "[" & sSectionName & "]"
   
9.         Print #Handle, "ColNameHeader =True"
   
10.         Print #Handle, "MaxScanRows = 0"
    
11.         Print #Handle, "Format = Delimited(,)"
    
12.         Print #Handle, "Col1=人员编号 Char Width 17"
    
13.         Print #Handle, "Col2=姓名 Char Width 8"
    
14.         Print #Handle, "Col3=应发工资 Currency"
    
15.         Print #Handle, "Col4=职务岗位工资 Currency"
    
16.         Print #Handle, "Col5=级别薪级工资 Currency"
    
17.         Print #Handle, "Col6=绩效工资 Currency"
    
18.         Print #Handle, "Col7=教护龄津贴 Currency"
    
19.         Print #Handle, "Col8=警衔津贴 Currency"
    
20.         Print #Handle, "Col9=工作津贴 Currency"
    
21.         Print #Handle, "Col9=工作津贴 Currency"
    
22.         Print #Handle, "Col10=生活补贴 Currency"
    
23.         Print #Handle, "Col11=岗位津贴 Currency"
    
24.         Print #Handle, "Col12=职务津贴 Currency"
    
25.         Print #Handle, "Col13=地区津贴 Currency"
    
26.         Print #Handle, "Col14=考勤奖 Currency"
    
27.         Print #Handle, "Col15=行业性津贴 Currency"
    
28.         Print #Handle, "Col16=提租补贴 Currency"
    
29.         Print #Handle, "Col17=保留工资 Currency"
    
30.         Print #Handle, "Col18=浮动工资 Currency"
    
31.         Print #Handle, "Col19=其他应发 Currency"
    
32.         Print #Handle, "Col20=一次性补扣发 Currency"
    
33.         Print #Handle, "Col21=代扣金额 Currency"
    
34.         Print #Handle, "Col22=住房公积金 Currency"
    
35.         Print #Handle, "Col23=养老保险金 Currency"
    
36.         Print #Handle, "Col24=失业保险金 Currency"
    
37.         Print #Handle, "Col25=医疗保险金 Currency"
    
38.         Print #Handle, "Col26=个人所得税 Currency"
    
39.         Print #Handle, "Col27=水电费 Currency"
    
40.         Print #Handle, "Col28=房租费 Currency"
    
41.         Print #Handle, "Col29=其他代扣 Currency"
    
42.         Print #Handle, "Col30=实发工资 Currency"
    
43.         
    
44.         Close Handle
    
45. 
    
46. End Sub

复制代码

lipton

借用2楼的代码：
代码在win7 office2010测试通过。

1. Sub test()
   
2.   Dim fso As New FileSystemObject
   
3.   Dim cnn As New ADODB.Connection
   
4.   Dim rs As New ADODB.Recordset
   
5.   Dim sql As String
   
6.   Dim strconn As String
   
7.   Dim ws As Worksheet
   
8.   Dim bln As Boolean
   
9.   
   
10.   If MsgBox("提取数据将删除本工作簿除[总表]以外的其他数据表并重新生成，确定提取吗？", vbOKCancel + vbCritical + vbDefaultButton2, "提示") = vbCancel Then
    
11.     Exit Sub
    
12.   End If
    
13.   
    
14.   Dim mybook As String
    
15.   Dim mysheet As String
    
16.   
    
17.   Application.DisplayAlerts = False
    
18.   Application.ScreenUpdating = False
    
19.   
    
20.     For Each ws In Worksheets
    
21.       If ws.Name <> "总表" Then
    
22.         ws.Delete
    
23.       End If
    
24.     Next
    
25.    
    
26.     mybook = ThisWorkbook.FullName
    
27.     mysheet = "sheet1"
    
28.     With cnn
    
29.           .Provider = "Microsoft.Jet.OLEDB.4.0"
    
30.           '.Provider = "Microsoft.ace.OLEDB.12.0"
    
31.     End With
    
32.     strconn = "Data Source=" & ThisWorkbook.Path & ";Extended Properties='TEXT;HDR=YES';"
    
33.    
    
34.     cnn.Open strconn
    
35.    
    
36.     Set f = fso.GetFolder(ThisWorkbook.Path)
    
37.    
    
38.     Dim strPath As String
    
39.     strPath = ThisWorkbook.Path & ""
    
40.   
    
41.     For Each wj In f.Files
    
42.         If wj.Name Like "*.txt" Then
    
43.             
    
44.             CreateSchemaFile strPath, wj.Name '添加Schema.ini文件
    
45.             
    
46.             Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
47.             ws.Name = Left(wj.Name, Len(wj.Name) - 4)
    
48.             sql = "select * from " & wj.Name
    
49.             rs.Open sql, cnn, adOpenKeyset, adLockOptimistic, adCmdText
    
50.             For i = 0 To rs.Fields.Count - 1
    
51.                 ws.Cells(1, i + 1) = rs.Fields(i).Name
    
52.             Next i
    
53.             ws.Range("a2").CopyFromRecordset rs
    
54.             ws.Columns("A:A").EntireColumn.AutoFit
    
55.             rs.Close
    
56.    
    
57.         End If
    
58.     Next
    
59.       
    
60.   Application.DisplayAlerts = True
    
61.   Application.ScreenUpdating = True
    
62.   Set rs = Nothing
    
63.   cnn.Close
    
64.   Set fso = Nothing
    
65.   Set cnn = Nothing
    
66. End Sub

复制代码