[已解决]把同一路径的其它文档的指定列的内容批量替换，谢谢爱疯老师！

lhj323323

老师：

我想把同一路径的其它文档的指定列的内容批量替换

在附件中的模板.xls里有详细的说明，请看看。先谢谢了
求助.rar (14.17 KB, 下载次数: 11)

2016-4-29 23:23 上传

点击文件名下载附件


这段需求的真实意图就是
在我不打开外部文档的情况下，清空sheet1工作表内第一行含有特定字符(即包含股东两字的字符)所在的一整列，同时，该列仍保留，只是，该列的内容是空白的。

最佳答案

月排行榜 / 总排行榜

爱疯

2016-4-30 20:34

Option Explicit

'主程序
Sub test1()
    Dim cfg, p, f
    Application.ScreenUpdating = False
    cfg = ThisWorkbook.Sheets(1).[r1].CurrentRegion
    p = ThisWorkbook.Path & "\"
    f = Dir(p)
    Do While f <> ""
        Call test2(cfg, p, f)
        f = Dir
    Loop
End Sub

'运行工作簿的条件：指定扩展名、不是本工作簿
Sub test2(cfg, p, f)
    Dim i
    For i = 2 To UBound(cfg)
        If f = ThisWorkbook.Name Then Exit Sub
        If InStr(1, f, cfg(i, 1), vbTextCompare) Then Call test3(cfg, p, f): Exit Sub
    Next i
End Sub

'操作某一个工作簿
Sub test3(cfg, p, f)
    Dim A, i, j, k
    With Workbooks.Open(p & f)
        A = .Sheets(1).Range("a1").CurrentRegion
        For k = 2 To UBound(cfg)
            For j = 1 To UBound(A, 2)
                If cfg(k, 2) = A(1, j) Then
                    '替换
                    For i = 2 To UBound(A)
                        A(i, j) = cfg(2, 3)
                    Next i
                    .Sheets(1).[a1].Resize(UBound(A), UBound(A, 2)) = A
                    .Close True
                    Exit Sub
                End If
            Next j
        Next k
        .Close False
    End With
End Sub

求助2.rar (23.63 KB, 下载次数: 15)

2016-4-30 20:34 上传

点击文件名下载附件

跳转到最佳答案楼层

today0427

1. Sub tihuan()
   
2.     Dim wb, wn, file
   
3.     Dim arr
   
4.     Dim i, ro, co, str, str1, mypa
   
5.         str = InputBox("请输入需要替换的标题")
   
6.         str1 = InputBox("请输入替换后的内容")
   
7.         mypa = ThisWorkbook.Path & ""
   
8.         wb = Dir(mypa & "*.*")
   
9.         
   
10.         Application.DisplayAlerts = False
    
11.         Do While Len(wb) <> 0
    
12.             If wb <> "模板.xlsm" Then
    
13.             Set file = Workbooks.Open(mypa & wb)
    
14.             wn = Workbooks(wb).Sheets.Count
    
15.                For i = 1 To wn
    
16.                     With Workbooks(wb).Sheets(i)
    
17.                         If Not IsEmpty(.UsedRange) Then
    
18.                             arr = .UsedRange
    
19.                             For co = 1 To UBound(arr, 2)
    
20.                                 If arr(1, co) = str Then
    
21.                                     For ro = 2 To UBound(arr, 1)
    
22.                                         arr(ro, co) = str1
    
23.                                     Next ro
    
24.                                     .Cells(1, co).Resize(UBound(arr, 1), 1).Clear
    
25.                                     .Cells(1, co).Resize(UBound(arr, 1), 1) = Application.Index(arr, , co)
    
26.                                     Exit For
    
27.                                 End If
    
28.                             Next co
    
29.                         End If
    
30.                     End With
    
31.                 Next i
    
32.             ActiveWorkbook.Save
    
33.             ActiveWorkbook.Close
    
34.         End If
    
35.             wb = Dir
    
36.         Loop
    
37.        Application.DisplayAlerts = True
    
38. End Sub
    

复制代码

today0427

不用管哪一列 也不用管什么后缀名的文件 只用在第一次出现的输入框输入需要替换字段的标题 如：股民信息 然后在第二次出现的输入框写上换成什么内容就行了 它会替换每个工作簿的每张工作表 结果在原表查看 btw 你的股东账户的账写错 害得我昨天替换不了找了半天原因

lhj323323

today0427 发表于 2016-4-30 07:06
不用管哪一列 也不用管什么后缀名的文件 只用在第一次出现的输入框输入需要替换字段的标题 如：股民信息 然 ...

该页内容删除

lhj323323

today0427 发表于 2016-4-30 06:55

老师：

我提及的外部文档中，我想替换或者想清空的列的第1行，一般都会取名叫
股东代码或股东账户，或股东帐户，或股东信息，等等

能否变通为如下思路？
从外部文档的SHEET1工作表中，历遍第一行，寻找包含“股东”这两个字所在的列，找到后，就清空该列（注意，不是删除该列）。

您看这样行吗？

这段需求的真实意图就是
在我不打开外部文档的情况下，清空sheet1工作表内第一行含有特定字符所在的一整列，同时，该列仍保留，只是，该列的内容是空白的。

爱疯

Option Explicit

'主程序
Sub test1()
    Dim cfg, p, f
    Application.ScreenUpdating = False
    cfg = ThisWorkbook.Sheets(1).[r1].CurrentRegion
    p = ThisWorkbook.Path & "\"
    f = Dir(p)
    Do While f <> ""
        Call test2(cfg, p, f)
        f = Dir
    Loop
End Sub

'运行工作簿的条件：指定扩展名、不是本工作簿
Sub test2(cfg, p, f)
    Dim i
    For i = 2 To UBound(cfg)
        If f = ThisWorkbook.Name Then Exit Sub
        If InStr(1, f, cfg(i, 1), vbTextCompare) Then Call test3(cfg, p, f): Exit Sub
    Next i
End Sub

'操作某一个工作簿
Sub test3(cfg, p, f)
    Dim A, i, j, k
    With Workbooks.Open(p & f)
        A = .Sheets(1).Range("a1").CurrentRegion
        For k = 2 To UBound(cfg)
            For j = 1 To UBound(A, 2)
                If cfg(k, 2) = A(1, j) Then
                    '替换
                    For i = 2 To UBound(A)
                        A(i, j) = cfg(2, 3)
                    Next i
                    .Sheets(1).[a1].Resize(UBound(A), UBound(A, 2)) = A
                    .Close True
                    Exit Sub
                End If
            Next j
        Next k
        .Close False
    End With
End Sub

求助2.rar (23.63 KB, 下载次数: 15)

2016-4-30 20:34 上传

点击文件名下载附件

lhj323323

爱疯 发表于 2016-4-30 20:34
Option Explicit

'主程序

爱疯老师：
运行程序后，一直在不停地读，我现在是强制退出的。

请问，是不是少了哪一句，停不下来，根本停不下来，呵呵

爱疯

lhj323323 发表于 2016-4-30 21:31
爱疯老师：
运行程序后，一直在不停地读，我现在是强制退出的。

你说的是6楼附件停不了吗？
如果不是，那上传一下停不了的文件

lhj323323

爱疯 发表于 2016-4-30 22:11
你说的是6楼附件停不了吗？
如果不是，那上传一下停不了的文件

好怪，我仍是停不了，只能强制退出。

谢谢爱疯老师，我晚上再研究一下。