把EXCEL数据导入到txt文档中的指定位置。谢谢liulang0808和一把小刀闯天下老师

lhj323323 · 发表于 2019-1-17 23:26

本帖最后由 lhj323323 于 2019-1-18 20:43 编辑

老师：
我想用VBA实现如下需求
把EXCEL的sheet1的A、B两列的内容，导入到同路径的mk.txt文档中的指定位置
同路径里，只有一个txt文档，且它的文件名永不变，即mk
同路径里，也只有这一个xls文档
mk.txt 里的原有内容，请保留，同时，原有内容中，[TRD]之下，是永远没有数据的。
具体的需求，请看附件。先谢谢老师了。

求助3.rar (6.83 KB, 下载次数: 14)

liulang0808 · 发表于 2019-1-18 08:20

Private Sub CommandButton1_Click()
Dim crr()
Application.ScreenUpdating = False
arr = ActiveSheet.[a1].CurrentRegion
Open ThisWorkbook.Path & "\mk.txt" For Input As #1
s = StrConv(InputB(LOF(1), 1), vbUnicode)
brr = Split(s, vbCrLf)
Close #1
ReDim crr(1 To UBound(brr) - 1 + UBound(arr) * 2)
For j = 0 To UBound(brr)
If brr(j) <> "[TIP]" Then
crr(j + 1) = brr(j)
Else
lb = j
lc = lb + 1
Exit For
End If
Next j
For j = 2 To UBound(arr)
If Len(arr(j, 1)) > 0 Then
crr(lc) = Format(arr(j, 1), "0000000") & "=7"
lc = lc + 1
End If
Next j
For j = lb To UBound(brr)
If Len(brr(j)) > 0 Then
crr(lc) = brr(j)
lc = lc + 1
End If
Next j
For j = 2 To UBound(arr)
If Len(arr(j, 1)) > 0 Then
crr(lc) = Format(arr(j, 1), "0000000") & "=" & arr(j, 2)
lc = lc + 1
End If
Next j
str1 = Join(crr, vbCrLf)
Open ThisWorkbook.Path & "\mk.txt" For Output As #1
Print #1, str1
Close #1
Application.ScreenUpdating = True
End Sub

复制代码

liulang0808 · 发表于 2019-1-18 08:21

附件内容供参考。。。。。。

一把小刀闯天下 · 发表于 2019-1-18 08:31

Option Explicit

Sub test()
Dim filename, i, j, arr, brr(), crr, cnt
filename = ThisWorkbook.Path & "\mk.txt"
If Dir(filename) = vbNullString Then MsgBox filename: Exit Sub
Open filename For Input As #1
arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbNewLine)
Close #1
ReDim brr(10 * UBound(arr))
crr = [a1].CurrentRegion
For i = 0 To UBound(arr)
   If Len(arr(i)) = 0 Then Exit For
   If arr(i) = "[TIP]" Then
      For j = 2 To UBound(crr, 1)
      cnt = cnt + 1
      brr(cnt) = String(7 - Len(crr(j, 1)), "0") & crr(j, 1) & "=7"
      Next
   End If
   cnt = cnt + 1: brr(cnt) = arr(i)
Next
For i = 2 To UBound(crr, 1)
   cnt = cnt + 1
   brr(cnt) = String(7 - Len(crr(i, 1)), "0") & crr(i, 1) & "=" & crr(i, 2)
Next
ReDim Preserve brr(cnt)
arr = Mid(Join(brr, vbNewLine), 3)
Open filename For Output As #1
Print #1, arr
Close #1
End Sub

xd3210 · 发表于 2019-1-18 09:24

API读写INI文件的方法：
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Dim Ret As Long
Dim Start As Long
Public FileName As String
Const BufSize = 10240
Dim buf As String * BufSize
Public Sub SetValue(ByVal clsName As String, ByVal key As String, ByVal V As String)
   Ret = WritePrivateProfileString(clsName, key, V, FileName)
End Sub
Public Function GetValue(ByVal clsName As String, ByVal key As String) As String
   Ret = GetPrivateProfileString(clsName, key, "", buf, BufSize, FileName)
   Start = 1
   GetValue = RetStr()
End Function
Sub wrini()
Dim arr
FileName = ThisWorkbook.Path & "\mk.txt"
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
      s = "0000000" + CStr(arr(i, 1))
      s = Right(s, 7)
      SetValue "MAK", s, "7"
      SetValue "TRD", s, CStr(arr(i, 2))
Next
End Sub