more

帖个VBA的.

Option Explicit

Sub Try()
    Dim lngRow As Long, i As Integer, objFso As Object, objFolder As Object, arrData, _
        objFl As Object, objOpFl As Object, strPth As String, intCol As Integer, strTime As String, intSh As Integer

    strPth = "f:\zhubi"     '在此指定要处理的目标文件夹
    Set objFso = CreateObject("scripting.filesystemobject")
    If objFso.folderexists(strPth) = False Then
        MsgBox "文件夹" & Chr(34) & strPth & Chr(34) & "不存在!!!" & Chr(10) & vbCrLf & _
            "请按 Alt + F11 打开 VBE 编辑器指定新的路径...", 48, " ：("
        Set objFso = Nothing
        Exit Sub
    End If
    strTime = Time
    intSh = 1
    Sheets(intSh).Select
    Application.ScreenUpdating = False
    Range("a1:iv65536").ClearContents
    Cells(1, 1) = "名称": Cells(1, 2) = "日期"
    Set objFolder = objFso.getfolder(strPth)
    Set objOpFl = objFso.opentextfile(strPth & "\" & "内盘笔4.txt", 1)
    lngRow = 1: intCol = 2
    Do Until objOpFl.atendofstream
        arrData = Split(objOpFl.readline, vbTab, -1, 1)
        lngRow = lngRow + 1
        Cells(lngRow, 1) = arrData(0): Cells(lngRow, 2) = arrData(1)
    Loop
    objOpFl.Close
    For Each objFl In objFolder.Files
        If objFso.GetExtensionName(strPth & "\" & objFl.Name) = "txt" Then
            Set objOpFl = objFso.opentextfile(strPth & "\" & objFl.Name)
            lngRow = 1: intCol = intCol + 1
            If intCol > 256 Then
                intCol = 1: intSh = intSh + 1
                For i = 1 To 256
                    Columns(i).AutoFit
                Next i
                Sheets(intSh).Select
            End If
            Cells(1, intCol) = objFso.GetbaseName(objFl.Name)
            Do Until objOpFl.atendofstream
                arrData = Split(objOpFl.readline, vbTab, -1, 1)
                lngRow = lngRow + 1
                Cells(lngRow, intCol) = arrData(2)
            Loop
            objOpFl.Close
        End If
    Next
    Set objFso = Nothing: Set objFolder = Nothing: Set objOpFl = Nothing
    For i = 1 To Range("iv1").End(xlToLeft).Column
        Columns(i).AutoFit
    Next i
    Application.ScreenUpdating = True
    MsgBox strTime & vbCrLf & Time & Chr(10) & "Done!", 0, "Right?"
End Sub
复制代码

在本机上就楼主上传的附件,用namejm的批代码要几分钟时间,而VBA仅一两秒钟,效率简直一个天一个地...

代码贴错了,改一改...

随风

又是一个挑战效率的文本题
想起好像有个 Hitme 前辈，
初学批处理时看到他的代码经常使用大量的临时文件来完成任务，现也模仿下 ^_^
我理解题意为：结果文件将会有262列，每列为某单个文件的第3列
思路：
  先生成260个临时文件，以文本的第1、2列为文件名，第3列为内容
  再将所有文件合为一个文件，将单个文件的所有内容合为一行即可
  
创建测试环境太麻烦，故代码未经测试，只是想当然 ^_^
若楼主回头看见此帖，还请测试后回复一下结果是否正确，且耗时如何。
此代码只有针对性没有通用性，是专对楼主题意解的。

@echo off
set var=内盘 外盘 内盘笔 外盘笔 委买 委卖 委买笔 委卖笔
md tem
for %%i in (%var%) do (
   for /l %%L in (1 1 31) do (
      for /f "tokens=1-3" %%a in (%%i%%L.txt) do >>"tem\%%a %%b.txt" echo %%c
    )
)
set num=内盘成交笔数 内盘成交量 内盘单笔最大成交量 外盘成交笔数 外盘成交量 外盘单笔最大成交量
set num=%num% 委托买入总量 委买总笔 委买单笔最大成交量 委托卖出总量 委卖总笔 委卖单笔最大成交量
set /p=名称 日期 %var% %num%<nul>test.txt
for %%i in (%num%) do (
   for /f "tokens=1-3" %%a in (%%i.txt) do >>"tem\%%a %%b" echo %%c
)
set lj=%cd%
cd/d tem
for %%i in (*.txt) do (
   set/p=%%~ni<nul>>"%lj%\test.txt"
   for /f "usebackq delims=" %%a in ("%%i") do set /p= %%a<nul>>"%lj%\test.txt"
   echo;
)
cd..
rd /s /q tem
start test.txt
复制代码

[ 本帖最后由 随风 于 2010-5-3 18:04 编辑 ]

w96692

原帖由 more 于 2010-5-2 12:43 发表
帖个VBA的.Option Explicit

Sub Try()
    Dim lngRow As Long, i As Integer, objFso As Object, objFolder As Object, arrData, _
        objFl As Object, objOpFl As Object, strPth As String, intCol As ...

感谢关注，附上测试结果，excel2007运行19秒完成所有文件，还未看正确性，就效率而言，牛！！！！！

[ 本帖最后由 w96692 于 2010-5-3 14:02 编辑 ]

w96692

原帖由 随风 于 2010-5-2 22:57 发表
又是一个挑战效率的文本题
想起好像有个 Hitme 前辈，
初学批处理时看到他的代码经常使用大量的临时文件来完成任务，现也模仿下 ^_^
我理解题意为：结果文件将会有262列，每列为某单个文件的第3列
思路：
  先生 ...

我看您理解的意思也对，但代码不能运行，不知何故？（放到别的盘下运行出一个有表头的txt文本，放到zhubi文件夹下不运行）