如图，F1到F12的内容是一样的，在F1那行插入空白，同样内容则不插入。直到检查到F13内容变了，也跟着整行插入空白。就这样一直循环此动作，直到F列检查到空白了就运行指定的宏。
第1个回答 2014-08-10
Sub 查找表中内容() '找到后打开该工作簿文件
On Error Resume Next
Dim PH As String, Name1 As String, Name2 As String, S As String
Dim ob1 As Object, Wb As Workbook
Dim G As Integer, N As Integer, N1 As Integer
PH = InputBox("请输入要查找字符的文件夹:", "提示信息", "d:\my")
S = InputBox("请输入要查找的字符:", "提示信息")
PH = IIf(Right(PH, 1) = "\", PH, PH & "\")
Name2 = Dir(PH & "*.xls")
Name1 = ActiveWorkbook.Name
Stop
Do While Name2 <> "" And S <> ""
If Name1 <> Name2 Then
Set Wb = Workbooks.Open(PH & "\" & Name2)
N = N + 1
For G = 1 To Sheets.Count
Sheets(G).Activate
For Each ob1 In ActiveSheet.UsedRange
If InStr(ob1.Value, S) > 0 Then N1 = N1 + 1: ob1.Select: GoTo w1
Next ob1
Next G
Wb.Close
End If
w1: Name2 = Dir
Loop
MsgBox ("在“" & PH & "”文件夹中共查找了 " & N & " 个Excel文件，" & Chr(13) & "文件内容中有“" & S & "”的文件有 " & N1 & " 个。")
Workbooks(Name1).Close
End Sub
以上程序能满足你的要求
On Error Resume Next
Dim PH As String, Name1 As String, Name2 As String, S As String
Dim ob1 As Object, Wb As Workbook
Dim G As Integer, N As Integer, N1 As Integer
PH = InputBox("请输入要查找字符的文件夹:", "提示信息", "d:\my")
S = InputBox("请输入要查找的字符:", "提示信息")
PH = IIf(Right(PH, 1) = "\", PH, PH & "\")
Name2 = Dir(PH & "*.xls")
Name1 = ActiveWorkbook.Name
Stop
Do While Name2 <> "" And S <> ""
If Name1 <> Name2 Then
Set Wb = Workbooks.Open(PH & "\" & Name2)
N = N + 1
For G = 1 To Sheets.Count
Sheets(G).Activate
For Each ob1 In ActiveSheet.UsedRange
If InStr(ob1.Value, S) > 0 Then N1 = N1 + 1: ob1.Select: GoTo w1
Next ob1
Next G
Wb.Close
End If
w1: Name2 = Dir
Loop
MsgBox ("在“" & PH & "”文件夹中共查找了 " & N & " 个Excel文件，" & Chr(13) & "文件内容中有“" & S & "”的文件有 " & N1 & " 个。")
Workbooks(Name1).Close
End Sub
以上程序能满足你的要求
第2个回答 推荐于2016-02-17
用辅助列公式就可以完成
用VBA的话运行如下代码
Sub Ins_Row()
ro = [f60000].End(xlUp).Row
For a = ro To 1 Step -1
If Cells(a, 6) <> Cells(a + 1, 6) Then Cells(a + 1, 6).EntireRow.Insert
Next
End Sub追问
用VBA的话运行如下代码
Sub Ins_Row()
ro = [f60000].End(xlUp).Row
For a = ro To 1 Step -1
If Cells(a, 6) <> Cells(a + 1, 6) Then Cells(a + 1, 6).EntireRow.Insert
Next
End Sub追问
谢谢，帮到忙啦。但是第一行却没有添加空白。请大神帮我第一行也加入空白
追答哈哈 疏漏了 next后面再加一句 Cells(1, 6).EntireRow.Insert
本回答被提问者和网友采纳