替换代码求解

779846526

替换问题.zip (36.66 KB, 下载次数: 15)

2016-3-31 14:35 上传

点击文件名下载附件

求助个批量替换工具：先在替换表上填写好被替换值和新值，点替换按钮后出现寻找文件的选择框，再选中要替换的工作簿，点确定后出现一窗体，在窗体中出现各个工作表的表名，再勾选不同的工作表并确定后，就能对勾选的工作表的内容进行批量替换。                                       
                                       
                                       
                                       
                                       
                                       
                                       
                                       
                                       
                                       
                                       

779846526

不知问题的意思说明白了吗？

779846526

难道是意思没说明白吗

779846526

在线等啊‘

779846526

急用啊，求好心人帮忙啊

779846526

再次求助中

zhaogang1960

请参考：
模块代码Public arr$(), brr$()

Sub Macro1()
    Dim Fso As Object, Folder As Object
    Dim m&
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = Fso.GetFolder(ThisWorkbook.Path)
    Call GetFiles(Folder, m)
    If m > 0 Then
        UserForm1.Show
    Else
        MsgBox "没有发现可以操作的文件！", vbInformation, "提示"
    End If
    Set Folder = Nothing
    Set Fso = Nothing
End Sub

Sub GetFiles(ByVal Folder As Object, ByRef m&)
    Dim SubFolder As Object
    Dim File As Object
    Dim rs As Object, cnn As Object
    Dim s$
    For Each File In Folder.Files
        If File.Name Like "*.xlsx" Then
            Set cnn = CreateObject("ADODB.Connection")
            cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & File.Path
            Set rs = cnn.OpenSchema(20)
            Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                    s = Replace(rs("TABLE_NAME").Value, "'", "")
                    If Right(s, 1) = "$" Then
                        m = m + 1
                        ReDim Preserve arr(1 To 2, 1 To m)
                        ReDim Preserve brr(1 To m)
                        arr(1, m) = Replace(File.Name, ".xls", "")
                        arr(2, m) = Replace(s, "$", "")
                        brr(m) = File
                    End If
                End If
                rs.MoveNext
            Loop
        End If
    Next
    Set rs = Nothing
    Set cnn = Nothing
End Sub

zhaogang1960

模块代码：

zhaogang1960

窗体代码

Private Sub CheckBox1_Click() '全选
    Dim f As Boolean, i&
    f = CheckBox1.Value
    With ListBox1
        For i = 0 To .ListCount - 1
            .Selected(i) = f
        Next
    End With
End Sub

Private Sub CommandButton1_Click()
    Dim arr, i&, m&, n&, d As Object, wb As Workbook
    Application.ScreenUpdating = False
    arr = [a1].CurrentRegion
    If [c1] = "匹配替换" Then n = 1 Else n = 2
    Set d = CreateObject("scripting.dictionary")
    With ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                If Not d.Exists(brr(i + 1)) Then
                    m = m + 1
                    If m > 1 Then wb.Close 1
                    d(brr(i + 1)) = ""
                    Set wb = Workbooks.Open(brr(i + 1))
                End If
                With wb.Sheets(.List(i, 1)).UsedRange
                    For j = 2 To UBound(arr)
                        .Replace arr(j, 1), arr(j, 2), n
                    Next
                End With
            End If
        Next
    End With
    wb.Close 1
    Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
    With ListBox1
        .RowSource = ""
        .ColumnCount = 2
        If UBound(arr, 2) > 1 Then
            .List = WorksheetFunction.Transpose(arr)
        Else
            .AddItem arr(1, 1)
            .List(0, 1) = arr(2, 1)
        End If
        .MultiSelect = fmMultiSelectMulti
        .ListStyle = fmListStyleOption
    End With
End Sub

Private Sub CommandButton2_Click() '退出
    Unload Me
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '退出窗体时清空数组
    Erase arr, brr
End Sub

zhaogang1960

请测试附件
替换问题.rar (56.86 KB, 下载次数: 83)

2016-3-31 23:00 上传

点击文件名下载附件