[已解决]请教各位大神：如何从TXT文件中获取特定位置的数据转到同文件名的excel表格里

beachum

在同一文件夹里，有同名的TXT文件和Excel文件，需要从TXT文件中获取特定位置的数据转到同文件名的Excel表格中，望各路大神予以指导 , 谢谢！

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-7-30 23:37

Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Set fso = CreateObject("scripting.filesystemobject")
   Set conn = CreateObject("adodb.connection")
   Set rs = CreateObject("adodb.recordset")
   Path = ThisWorkbook.Path & "\"
   conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='text;HDR=No';Data Source =" & Path
   
   For Each file In fso.getfolder(ThisWorkbook.Path).Files
      If Not file.Name Like "*.txt" Then GoTo 1
      Sql = "select * from " & file.Name
      rs.Open Sql, conn, 3, 3
      If rs.RecordCount <> 0 Then
          [a1:g10000].ClearContents
         [a1].CopyFromRecordset rs
         [a:a].TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Space:=True
      End If
      rs.Close
      Range("b:b,c:c,d:d,f:f,g:g").Delete
      Range("c1,d1,g1,h1") = Range("b1")
      Range("e1,f1,i1") = 0
      Range("c2") = "=2/(12+1)*B2+(1-2/(12+1))*C1"
      Range("d2") = "=2/(26+1)*B2+(1-2/(26+1))*D1"
      Range("e2") = "=C2-D2"
      Range("f2") = "=2/(9+1)*E2+(1-2/(9+1))*F1"
      Range("g2") = "=2/(12+1)*C2+(1-2/(12+1))*G1"
      Range("h2") = "=2/(12+1)*G2+(1-2/(12+1))*H1"
      Range("i2") = "=(H2-H1)/H1*100"
      r = [b1].End(4).Row
      Range("c2:i2").AutoFill Destination:=Range("c2:i" & r)
      Range("j9") = "=AVERAGE(I1:I9)"
      Range("j9").AutoFill Destination:=Range("j9:j" & r)
      NewFile = Path & Split(file.Name, ".")(0) & ".xlsx"
      ActiveWorkbook.SaveAs Filename:=NewFile, FileFormat:=xlOpenXMLWorkbook
1:
   Next
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Application.Quit
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Set fso = CreateObject("scripting.filesystemobject")
   Set conn = CreateObject("adodb.connection")
   Set rs = CreateObject("adodb.recordset")
   Path = ThisWorkbook.Path & "\"
   conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='text;HDR=No';Data Source =" & Path
   
   For Each file In fso.getfolder(ThisWorkbook.Path).Files
      If Not file.Name Like "*.txt" Then GoTo 1
      Sql = "select * from " & file.Name
      rs.Open Sql, conn, 3, 3
      If rs.RecordCount <> 0 Then
          [a1:g10000].ClearContents
         [a1].CopyFromRecordset rs
         [a:a].TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Space:=True
      End If
      rs.Close
      Range("b:b,c:c,d:d,f:f,g:g").Delete
      Range("c1,d1,g1,h1") = Range("b1")
      Range("e1,f1,i1") = 0
      Range("c2") = "=2/(12+1)*B2+(1-2/(12+1))*C1"
      Range("d2") = "=2/(26+1)*B2+(1-2/(26+1))*D1"
      Range("e2") = "=C2-D2"
      Range("f2") = "=2/(9+1)*E2+(1-2/(9+1))*F1"
      Range("g2") = "=2/(12+1)*C2+(1-2/(12+1))*G1"
      Range("h2") = "=2/(12+1)*G2+(1-2/(12+1))*H1"
      Range("i2") = "=(H2-H1)/H1*100"
      r = [b1].End(4).Row
      Range("c2:i2").AutoFill Destination:=Range("c2:i" & r)
      Range("j9") = "=AVERAGE(I1:I9)"
      Range("j9").AutoFill Destination:=Range("j9:j" & r)
      NewFile = Path & Split(file.Name, ".")(0) & ".xlsx"
      ActiveWorkbook.SaveAs Filename:=NewFile, FileFormat:=xlOpenXMLWorkbook
1:
   Next
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Application.Quit
End Sub

祝順心，南無阿彌陀佛！

风林火山

    Dim arr, strxlsx As String, strtxt As String, wk As Workbook, n As Byte
    Dim iRow As Long, a, b, c(), m
    On Error Resume Next
    arr = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", 2, , True)
    If arr(1) <> "flase" Then
        For n = 1 To UBound(arr)
            Set wk = Application.Workbooks.Open(arr(n))
            iRow = ActiveSheet.Cells(Rows.Count, 1).End(3).Row + 1
            strtxt = ActiveWorkbook.Path & "/" & Replace(ActiveWorkbook.Name, ".xlsx", "") & ".txt"

            Open strtxt For Input As #1

                Do While Not EOF(1)
                    Line Input #1, a
                    If InStr(a, "通达") = 0 Then
                        b = Split(a, " ")
                        m = m + 1
                        ReDim Preserve c(1 To 2, 1 To m)
                        c(1, m) = b(0): c(2, m) = b(4)
                        Erase b
                    End If
                Loop
            Close #1

            Cells(iRow, 1).Resize(m, 2) = Application.WorksheetFunction.Transpose(c)
            iRow = ActiveSheet.Cells(Rows.Count, 1).End(3).Row + 1
            wk.Close
            Set wk = Nothing
        Next n
    End If
End Sub

beachum

cutecpu 发表于 2021-7-30 23:37
Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

cutecpu大神 非常感谢您的帮助！
在实际运行代码的时候，会遇到图片中的情况，怎么才能防止多出的行？
以及在运行这个代码时，能不能去掉最后一行中的“数据来源通达信”这行字？

cutecpu

beachum 发表于 2021-8-2 13:04
cutecpu大神 非常感谢您的帮助！
在实际运行代码的时候，会遇到图片中的情况，怎么才能防止多出的行？
...

在原代码里，加上红色部份即可

If rs.RecordCount <> 0 Then
    Cells.Clear
    [a1].CopyFromRecordset rs
    [a:a].TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Space:=True
    Cells([a1].End(4).Row, 1) = ""
End If

※测资跟代码可以压在一起，不用分成两个檔喔

祝順心，南無阿彌陀佛！

beachum

cutecpu 发表于 2021-8-2 14:19
在原代码里，加上红色部份即可

If rs.RecordCount  0 Then

遇到多个只有（数据来源：通达信）的TXT文件时，运行起来像死机了。
想加（If Range("A2") <> "" Then）和（End If），来解决，但感觉哪儿还是不对。
请大神指教！

cutecpu

beachum 发表于 2021-8-2 17:27
遇到多个只有（数据来源：通达信）的TXT文件时，运行起来像死机了。
想加（If Range("A2")  "" Then）和 ...

1. rs.Close 下面，加一行：   If [a2] = 0 Then GoTo 1

2. 把最后
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    拿掉
    只留下
    Application.Quit

beachum

cutecpu 发表于 2021-8-2 18:52
1. rs.Close 下面，加一行：   If [a2] = 0 Then GoTo 1

2. 把最后

十分感谢您！效果非常好！

因为实际需要，我对您的代码进行了扩展，
想对G ，H ，M，N，S，T列，显示计算后
的结果取小数点后两位（四舍五入），使用：Range(Cells(1, 7), Cells(endrow, 8)).NumberFormatLocal = "0.00_ "
行不通，请大神指点一下！
谢谢！

cutecpu

beachum 发表于 2021-8-7 16:48
十分感谢您！效果非常好！

因为实际需要，我对您的代码进行了扩展，

Range("g:g,h:h,m:m,n:n,s:s,t:t").NumberFormatLocal = "0.00_ "


祝順心，南無阿彌陀佛！

beachum

cutecpu 发表于 2021-8-7 17:48
Range("g:g,h:h,m:m,n:n,s:s,t:t").NumberFormatLocal = "0.00_ "

完美！谢谢大神！！！