ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2602|回复: 3

[问卷征集] 求 很繁琐的文本数据整理 VBA 解法

[复制链接]

TA的精华主题

TA的得分主题

发表于 2009-10-22 11:40 | 显示全部楼层 |阅读模式
100财富
原帖子见:http://club.excelhome.net/thread-494271-1-1.html

各位老师好
今有一难题。。。
之前找了很多文本整理软件,都没看到能最终实现此文本处理的工具
在EXCEL里要处理起来很是繁琐。

我是先查找 含有{3D  文本的所有行数,然后删除,然后查找含有 :2-3 的所有行数,再删除,然后……
嗯好繁琐。。。

在此向各位老师求解,,
能不能用VBA一键解决了

问题附件见原帖附件,万分感谢  

压缩包里的:待处理就是要整理的文本,处理后的就是想要的结果的文本。。。

最佳答案

查看完整内容

新加一个模块。将下面代码粘贴进去。 注意Test过程中的文件名。

TA的精华主题

TA的得分主题

发表于 2009-10-22 11:40 | 显示全部楼层
新加一个模块。将下面代码粘贴进去。
注意Test过程中的文件名。

  1. Option Explicit

  2. Public Function 文本处理(ByVal FileName1 As String, ByVal FileName2 As String)
  3. 'FileName1:要处理的文件名
  4. 'FileName2:处理后保存的文件名(注:如果文件已经存在,将删除原文件)

  5.   Dim I As Long, FileL As Long
  6.   Dim byteD() As Byte
  7.   Dim strFiles() As String, strFile As String
  8.   
  9.   On Error Resume Next
  10.   
  11.   FileL = FileLen(FileName1)
  12.   If FileL > 0 Then
  13.     ReDim byteD(FileL - 1)
  14.     FileL = FreeFile
  15.     Open FileName1 For Binary As FileL
  16.     Get FileL, , byteD
  17.     Close FileL
  18.     strFile = StrConv(byteD, vbUnicode)
  19.     Erase byteD
  20.     strFiles = Split(Replace(Replace(strFile, """", vbNullString), " ", vbNullString), vbCrLf)
  21.     strFile = vbNullString
  22.     For I = 0 To UBound(strFiles)
  23.       Select Case True
  24.         Case Mid(strFiles(I), 1, 1) = ":":          strFile = Mid(strFile, 1, Len(strFile) - 1) & vbCrLf
  25.         Case IsNumeric(Split(strFiles(I), "=")(0)): strFile = strFile & Replace(Split(strFiles(I), "=")(1), " ", vbNullString)
  26.       End Select
  27.     Next I
  28.     byteD = StrConv(strFile, vbFromUnicode)
  29.     FileL = FreeFile
  30.     If Len(Dir(FileName2, vbHidden Or vbNormal Or vbReadOnly Or vbSystem Or vbArchive)) Then
  31.       SetAttr FileName2, vbNormal
  32.       Kill FileName2
  33.     End If
  34.     Open FileName2 For Binary As FileL
  35.     Put FileL, , byteD
  36.     Close FileL
  37.     Erase byteD
  38.     Erase strFiles
  39.     strFile = vbNullString
  40.   End If
  41. End Function

  42. Public Sub Test()
  43.   文本处理 ThisWorkbook.Path & "\待处理.txt", ThisWorkbook.Path & "\处理1.txt"
  44. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-10-22 13:35 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
嗯。。

谢谢老师到这里 解答···

TA的精华主题

TA的得分主题

发表于 2009-10-22 15:08 | 显示全部楼层

  1. Private Sub CommandButton1_Click()
  2.     Dim irow%, Arr(999)
  3.     Dim str$, st$
  4.     Dim k%, i%

  5.     Open ThisWorkbook.Path & "\待处理.txt" For Input As #1
  6.     k = 0
  7.     i = -1
  8.     str = ""
  9.     Do Until EOF(1)

  10.         Line Input #1, st

  11.         If Mid(st, 3, 1) <> "=" Then GoTo 1

  12.         k = k + 1
  13.         str = str & Replace(Split(st, "=")(1), " ", "")
  14.         str = Left(str, Len(str) - 1)
  15.         If k = 3 Then
  16.             k = 0
  17.             i = i + 1
  18.             Arr(i) = Left(str, Len(str) - 1)
  19.             str = ""
  20.         End If
  21. 1
  22.     Loop
  23.     Close #1

  24.     Open ThisWorkbook.Path & "\成组数据.txt" For Output As #1
  25.     For k = 0 To i
  26.         Print #1, Arr(k)
  27.     Next
  28.     Close #1
  29. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-1 07:46 , Processed in 0.046873 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表