请问哪位朋友知道,VBA实现查找出工作表内所有满足条件的行,并替换指定的单元格内容?
Sub ReplaceConditional()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rng As Range
Set rng = ws.Range("A1:D10")
Dim cell As Range
For Each cell In rng
If cell.Value = "foo" Then
cell.Value = "bar"
End If
Next cell
End Sub
Option Explicit
Option Compare Text
Sub 关键字查找工作簿行()
'Application.DisplayAlerts = False
Dim i1, i2, i3, i4, i5, i6, i7, b, j
Dim wb2 As Workbook
Dim eachSheet As Worksheet
Dim inpu As String
'选择多个文件
Dim l As Long
Dim full_file
b = 2
On Error Resume Next '忽略运行过程中可能出现的错误
Set wb2 = ThisWorkbook
MsgBox "通过关键字查找工作簿的行,如查找关键字:合计、汇总、总计……。查找时部分匹配,不是全匹配。查找不同工作簿中的多个工作表。汇总到工作表《汇总各表行》中,保留数值、格式,不保留公式。"
inpu = Application.InputBox("请输入需要查找的关键字(如合计、汇总等),是按照部分匹配查找,输入字符串必须准确,否则查找结果太多容易导致死锁:", Type:=2)
Dim sht As Worksheet '定义对象变量sht,用于表示工作表
On Error Resume Next '容错语句
Set sht = Sheets("汇总各表行") '将“成绩统计表”赋值给对象变量sht
If Err <> 0 Then '如果表格不存在,上面的赋值操作会出错,Err<>0表示有错误
Sheets.Add(, Sheets(Sheets.Count)).Name = "汇总各表行" '新建在最后面
Else
Debug.Print "该表已经存在" '如果没出错,说明表格存在,给出提示
End If
With Application.FileDialog(msoFileDialogFilePicker) '要全选ctrl + A
.AllowMultiSelect = True
'单选择
.Filters.Clear
'清除文件过滤器
.Filters.Add "Excel Files", "*.xls;*.xlsx;*.xlw"
.Filters.Add "All Files", "*.*"
'设置两个文件过滤器
.Show
For l = 1 To .SelectedItems.Count
full_file = .SelectedItems(l)
'Debug.Print full_file
Dim wkbk As Workbook '定义一个工作薄
Set wkbk = Workbooks.Open(full_file) '打开文件
For Each eachSheet In wkbk.Worksheets
If Not eachSheet.Name = "汇总各表行" Then
'Debug.Print eachSheet.UsedRange.Rows.Count, eachSheet.UsedRange.Columns.Count
j = eachSheet.UsedRange.Columns.Count
For i1 = 1 To eachSheet.UsedRange.Rows.Count '从第1行到最大行
For i2 = 1 To j '从第1列到最大列
If eachSheet.Cells(i1, i2) <> "" Then '如果单元格不是空白,则
i3 = InStr(1, eachSheet.Cells(i1, i2), inpu) '获取关键词所在位置
i6 = InStr(1, eachSheet.Cells(i1, i2), "洁")
If i6 > 0 Then '如果不存在关键词,则退出。因为复制一整行,不能保证同一行的其他单元格不含有i6所包含的字符串。
Exit For
Else:
If i3 > 0 Then '如果存在关键词,则
eachSheet.Range(Cells(i1, 1), Cells(i1, j)).Copy
wb2.Worksheets("汇总各表行").Cells(b, 3).PasteSpecial Paste:=xlPasteFormats
wb2.Worksheets("汇总各表行").Cells(b, 3).PasteSpecial Paste:=xlPasteValues
wb2.Worksheets("汇总各表行").Cells(b, 2).Value = eachSheet.Name
wb2.Worksheets("汇总各表行").Cells(b, 1).Value = wkbk.Name
b = b + 1
'Debug.Print wkbk.Name, eachSheet.Name, j
Exit For '退出For循环
End If
End If
End If
Next
Next
End If
Next
wkbk.Save: wkbk.Close True
Next
End With
Application.DisplayAlerts = True
End Sub
参考 VBA 查找和替换: https://blog.csdn.net/weixin_42298128/article/details/112629254
你看看这篇实例中讲解的方法符合你的要求不?
Sub replacetest()
Dim str As String
Dim str2 As String
str = "ababab"
'vba.Replace("在哪儿找","找什么(需要被替换掉的部分)","换成什么","从第几个字符开始找","替换几次","匹配方式")
'一共六个参数
'例1
str2 = Replace(str, "a", 1)
'把str中的全部替换为1
'str2 会被替换成1b1b1b
'例2
str2 = Replace(str, "a", 1, 3)
'第四个参数说明从第3个字符开始替换,替换结果会舍掉前两个字符。
'str2会被替换成1b1b
'例3
str2 = Replace(str, "a", 1, 3, 1)
'第五个参数是替换次数,默认是替换全部,设置为1的话,就只替换第一次出现的a;
'这句代码的意思是从第3个开始的第1个a
'str2会被替换为1bab
'例4
str2 = Replace(str, "A", 1, , , vbBinaryCompare)
'第六个参数为二进制匹配时,区分大小写;结果为ababab
str2 = Replace(str, "A", 1, , , vbTextCompare)
'第六个参数为文本匹配时,不区分大小写;结果为1b1b1b
MsgBox str2
End Sub