|
发表于 2016-7-7 21:13
|
显示全部楼层
本楼为最佳答案
本帖最后由 wanao2008 于 2016-7-7 21:15 编辑
终于给你弄好了,我是用正则来提取数据的,请测试- Sub wanao()
- Dim txtLine, OpenE As Integer, Lx As Integer
- Dim FileObj As Object, TextObj As Object, FilePath As Object, OpenText As Object
- Dim MyStr As String, tL As Integer, x As Integer
- Dim regEX As Object, mc
- '使用正则提取数据
- Set regEX = CreateObject("VBSCRIPT.REGEXP")
- With regEX
- .Global = True
- .IgnoreCase = True
- .Pattern = "\S+"
- End With
- Set FileObj = CreateObject("Scripting.FileSystemObject")
- Set FilePath = FileObj.getfolder(ThisWorkbook.Path & "\数据源")
- '用SHEET1的数据给SHEET2表制作个表头,如果你提前做好了,可删除下面这句
- Sheet1.Range("I9:M9").Copy Sheet2.Range("A1:E1")
- For Each OpenText In FilePath.Files
- OpenE = 0
- Lx = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
- '制作标题行
- If Lx > 2 Then Sheet2.Range("A1:E1").Copy Sheet2.Range("A" & Lx + 1 & ":E" & Lx + 1): Lx = Lx + 1
- Set TextObj = FileObj.OpenTextFile(OpenText, 1, True)
- For x = 1 To 50
- tt = TextObj.readline
- If Left(tt, 4) = "────" Then
- If OpenE = 1 Then Exit For
- OpenE = 1
- tt = TextObj.readline
- End If
- If OpenE = 1 Then
- Set mc = regEX.Execute(tt)
- If mc.Count = 5 Then
- Lx = Lx + 1
- For i = 0 To 4
- Sheet2.Cells(Lx, i + 1) = mc(i)
- Next
- ElseIf mc.Count = 1 Then
- Sheet2.Cells(Lx, 1) = Sheet2.Cells(Lx, 1) & mc(0)
- ElseIf mc.Count = 6 Then
- Lx = Lx + 1
- Sheet2.Cells(Lx, 1) = mc(0)
- Sheet2.Cells(Lx, 2) = mc(1)
- Sheet2.Cells(Lx, 3) = mc(2) & " " & mc(3)
- Sheet2.Cells(Lx, 4) = mc(4)
- Sheet2.Cells(Lx, 5) = mc(5)
- ElseIf mc.Count = 4 Then
- Lx = Lx + 1
- For i = 0 To 3
- Sheet2.Cells(Lx, i + 2) = mc(i)
- Next
- End If
- End If
- Next
- Next
- Set TextObj = Nothing
- Set FileObj = Nothing
- End Sub
复制代码 |
|