求更新TXT内容的代码，急，在线等……

一束阳光

内容在附件里。

TXT文件里原内容超过7万，为了便于上传，只保留了几行。

我从网上找了半天代码，只找到输出到TXT文件的一段代码，也在附件里，是把原内容覆盖了，不符合我的要求。

我每次只需要更新7万条里的其中的几十行。现缺少判断是否重复的代码，以及“追加”（不是覆盖）条目的代码。

请各大侠指点。

fiRhnyTG.rar (22.63 KB, 下载次数: 8)

2007-10-13 15:04 上传

点击文件名下载附件
求更新TXT内容的代码，急，在线等……

xinhunter

楼主想让人帮忙写完代码么？不如学习下如何操作TXT文件，比如以记录方式打开

另外提个建议，不要去判断是否重复，对相同编号的，一律重写，效率不会低于先判断再重写。

northwolves

可以应用字典对象:

Sub ChangeToText()
    Dim arr, dic As Object, i As Long
   Set dic = CreateObject("scripting.dictionary")
    Open ThisWorkbook.Path & "\TextData.txt" For Input As #1
    arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    Close #1
    For i = 0 To UBound(arr)
    If Len(arr(i)) > 0 Then dic.Add Split(arr(i), vbTab)(0), arr(i)
    Next
   
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
    If dic.exists(arr(i, 1)) Then
    dic(arr(i, 1)) = Join(Application.Index(arr, i, 0), vbTab)
    Else
    dic.Add arr(i, 1), Join(Application.Index(arr, i, 0), vbTab)
    End If
    Next
   
    Open ThisWorkbook.Path & "\TextData.txt" For Binary As #1
    Put #1, , Join(dic.items, vbCrLf)
    Close #1
    Set dic = Nothing
    MsgBox "ok"
End Sub

一束阳光

非常感谢二位。

一束阳光

首先非常感谢狼版的帮助。

我已经多次试用，基本符合要求了，还有一点问题。

每一行是一条完整的信息记录。第一列的内容是唯一的(比如取名叫“编号”)，将来判断一条信息是否存在，以第一列为准。在执行代码时会有三种情况：

1、“编号”在TXT文件里不存在。

2、“编号”在TXT文件里已经存在，并且后面的各列内容完全相同；

3、“编号”在TXT文件里已经存在，但后面的各列内容不完全相同；

第1种情况，增加新的信息行，狼版的代码可以实现。

第2、3种情况可以采取同一种处理方法，就是把原来的整行信息换成新的信息就OK了，但附件代码运行时，没有判断(可能只判断了新条目是不是和原条目的最后一条是否相同)，直接增加进去了。如果再运行一遍，就不再增加了，而是出错，提示“运行时错误'457'该关键字已经与该集合的一个元素相关联”。

 

 

ltip2pCm.rar (157.03 KB, 下载次数: 10)

2007-10-19 12:30 上传

点击文件名下载附件
求更新TXT内容的代码，急，在线等……

[此贴子已经被作者于2007-10-27 15:19:07编辑过]

northwolves

Sub ChangeToText()
    Dim arr, s() As String, i As Long
    Open ThisWorkbook.Path & "\TextData.txt" For Input As #1
    s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    Close #1
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
    For j = 1 To UBound(s)
    If s(j) Like arr(i, 1) & "*" Then s(j) = Join(Application.Index(arr, i, 0), vbTab): Exit For
    Next
    If j = UBound(s) + 1 Then s(j) = Join(Application.Index(arr, i, 0), vbTab)
    Next
    Open ThisWorkbook.Path & "\TextData.txt" For Binary As #1
    Put #1, , Join(s, vbCrLf)
    Close #1
   MsgBox "ok"
    End Sub

一束阳光

QUOTE:

以下是引用northwolves在2007-10-27 23:42:43的发言：
Sub ChangeToText()
    Dim arr, s() As String, i As Long
    Open ThisWorkbook.Path & "\TextData.txt" For Input As #1
    s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    Close #1
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
    For j = 1 To UBound(s)
    If s(j) Like arr(i, 1) & "*" Then s(j) = Join(Application.Index(arr, i, 0), vbTab): Exit For
    Next
    If j = UBound(s) + 1 Then s(j) = Join(Application.Index(arr, i, 0), vbTab)
    Next
    Open ThisWorkbook.Path & "\TextData.txt" For Binary As #1
    Put #1, , Join(s, vbCrLf)
    Close #1
   MsgBox "ok"
    End Sub

提示下标出界：

 

northwolves

笔误,改为:

  If j = UBound(s) + 1 Then s(i) = Join(Application.Index(arr, i, 0), vbTab)

eq800

我也来做个记号

一束阳光

非常非常感谢狼版主，你写的代码帮我大忙了。

[em24][em24][em24]

我想要的是这样子，用两段代码：

kA9YfBel.rar (11.54 KB, 下载次数: 25)

2007-11-26 12:59 上传

点击文件名下载附件

[此贴子已经被作者于2007-11-26 12:59:56编辑过]