使用VBA 实现文本内数据替换

雷沛qaz

使用VBA 实现文本内数据替换

饮冰e士

没看懂需要怎么操作

雷沛qaz

饮冰e士 发表于 2024-7-27 15:46
没看懂需要怎么操作

将我现有文件里边的83行数据，96行数据，使用VBA一次改成我需要的数据（即表格里边的数据）

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, cr, i&, j&, strTxt$, strFileName$, strPath$

    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    br = Array(82, 95)
    strPath = ThisWorkbook.Path & "\"
   
    With CreateObject("VBScript.RegExp")
        .Pattern = "[\d\.]+"
        For i = 3 To UBound(ar)
            strFileName = strPath & ar(i, 1) & ".b5r"
            If Dir(strFileName) <> "" Then
                strTxt = ReadFromTextFile(strFileName)
                cr = Split(strTxt, vbCrLf)
                For j = 0 To UBound(br)
                    If .test(cr(br(j))) Then
                        cr(br(j)) = .Replace(cr(br(j)), ar(i, j + 2))
                    End If
                Next j
                WriteToTextFile strFileName, Join(cr, vbCrLf)
            End If
        Next i
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function ReadFromTextFile$(ByVal strFullName$, Optional ByVal strCharSet$ = "UTF-8")
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Mode = 3
        .Charset = strCharSet
        .Open
        .LoadFromFile strFullName
        ReadFromTextFile = .ReadText
        .Close
    End With
End Function
Function WriteToTextFile(ByVal strFullName$, ByVal strTxt$, Optional ByVal strCharSet$ = "UTF-8")
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Mode = 3
        .Charset = strCharSet
        .Open
        .WriteText strTxt
        .SaveToFile strFullName, 2
        .flush
        .Close
    End With
End Function

gwjkkkkk

因为你要指定文件名，工作表中指定的文件名需改一下，请参考附件。。。。

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Sheets(1)
    arr = ws.Range("b3:c" & ws.Cells(Rows.Count, 3).End(3).Row)
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.b5r")
    Do While f <> ""
        With Workbooks.Open(p & f, 0).Sheets(1)
            x = Val(Replace(f, ".b5r", ""))
            .[a83] = arr(x, 1): .[a96] = arr(x, 2)
            .Parent.Close 1
        End With
        f = Dir
    Loop
    Beep
    Application.ScreenUpdating = True
End Sub

ykcbf1100

这个应该算重复发帖吧。
我把发在另一个帖子上的回复再回复一下吧。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.27
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     a = [{"1","2","3"}]
   
6.     b = [{"3996.8-4002.2","4002.2-3996.8","6655.6-4466.4"}]
   
7.     c = [{83,96}]
   
8.     For x = 1 To UBound(a)
   
9.         s = a(x)
   
10.         d(s) = b(x)
    
11.     Next
    
12.     p = ThisWorkbook.Path & ""
    
13.     For Each f In fso.GetFolder(p).Files
    
14.         If LCase$(f.Name) Like "*.b5r" Then
    
15.             fn = fso.GetBaseName(f)
    
16.             If d.exists(fn) Then
    
17.                 t = Split(d(fn), "-")
    
18.                 Set wb = Workbooks.Open(f, 0)
    
19.                 With wb.Sheets(1)
    
20.                     .Cells(c(1), 1) = Val(t(0))
    
21.                     .Cells(c(2), 1) = Val(t(1))
    
22.                 End With
    
23.                 wb.Close 1
    
24.             End If
    
25.         End If
    
26.     Next f
    
27.     Application.ScreenUpdating = True
    
28.     Set d = Nothing
    
29.     MsgBox "OK！"
    
30. End Sub

复制代码

雷沛qaz

ykcbf1100 发表于 2024-7-27 21:01
这个应该算重复发帖吧。
我把发在另一个帖子上的回复再回复一下吧。

这个里边数字变了，内容也只剩下数字了，不过还是感谢