VBA通过关键字查找工作簿、工作表的行

最新推荐文章于 2024-01-31 13:29:47 发布
最新推荐文章于 2024-01-31 13:29:47 发布
阅读量5k 收藏 21
点赞数 2
分类专栏： VBA 文章标签： 自动化
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/weixin_46655338/article/details/124751261
版权

一、通过关键字查找工作表的行方法1：

Option Explicit
Option Compare Text

Sub 关键字查找工作表行()
    'vba关于查找方法(Find方法)的应用(一)
    Dim findValue As Range
   
    Dim eachSheet As Worksheet
    Dim inpu As String
    Dim a, b
    b = 0
    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

    
    
    For Each eachSheet In Worksheets
        If Not eachSheet.Name = "汇总各表行" Then
            Set findValue = eachSheet.UsedRange.Find(what:=inpu)
            '查找内容为“黄”字，如果加上参数lookat:=xlWhole,就是完全匹配，单元格只有一个“黄”字才算找到，这里演示的是不指定，默认就是单元格内容“包含”这个字就可以了，注意的事，如果手动在查找替换窗口里把“单元格匹配”勾打上的话，这里不进行设置会直接按手动在“查找替换”窗口中设置的值进行查找。找到就把当前位置绝对位置赋值给变量，如果要取找到的单元格的值后面加.value，这样可以获取到所有包含指定字符的所有单元格内容。
            Debug.Print eachSheet.Name
            If Not findValue Is Nothing Then
                'is nothing 就是没事情发生，没有找到， 前面加一个not,那意思就相反了，就是找到有，也可以前面不加not，只需要把下面ELSE前后位置调一下就可以了。
                'MsgBox "第一个数据数据在单元格:" & findValue.Address '以上一次查找到的位置往下查找
                b = b + 1 '设置一个计数变量，统计一共找到多少个符合条件的
                a = findValue.Address '把第一个找到的地址赋值给变量a，以此对比是否已经全部查找完毕。
                eachSheet.Range(Cells(findValue.Row, 1), Cells(findValue.Row, 10)).Copy
                Worksheets("汇总各表行").Cells(b + 1, 2).PasteSpecial Paste:=xlPasteFormats
                Worksheets("汇总各表行").Cells(b + 1, 2).PasteSpecial Paste:=xlPasteValues
                
                Worksheets("汇总各表行").Cells(b + 1, 1).Value = eachSheet.Name
                 Do
                    '开始循环查找，一般使用Do循环命令会在前面设置一个循环条件或在后面设置一个终止条件，我这里前后都没有设置，而是在中间对条件进行判断，当查找结束就使用exit do命令退出do循环
                    'after前面要有findvalue，否则报错，do loop要在else之前
                    Set findValue = eachSheet.UsedRange.FindNext(After:=findValue)
                    '使用findnext继续往下查找,After参数是指定从哪个单元格的下一个开始查找，其中“:=”后面的findvalue是上一次查找到的位置对象变量，意思就是从这一个单元格的下一个单元格
                    If findValue.Address = a Then '如果当前的位置和最开始找到的位置一样，则
                        Set findValue = Rows.FindPrevious(After:=findValue) '以上一次查找到的位置继续往上查找，注意这个是往上查找，因为当前位置已经是最开始第一次找到的位置，往上找一次就是最后一个找到的位置。
                        'MsgBox ("一共找到" & b & "个")
                        'MsgBox "最后一个数据在单元格:" & findValue.Address
                        Exit Do
                    Else '否则，如果当前找到的位置不是第一次找到的位置
                        b = b + 1 '计数变量加1，并提示当时找到的是第几个符合条件的
                        'addr_find = findValue.Address
                        'MsgBox "第" & b & "个找到的数据发现在单元格:" & findValue.Address
                        'row_find = addr_find.Row
                        
                        'Debug.Print Rows(findValue.Row).Select
                        
                        'Worksheets("查找行").Range(Cells(findValue.Row, 1), Cells(findValue.Row, 10)).Select
                        eachSheet.Range(Cells(findValue.Row, 1), Cells(findValue.Row, 10)).Copy
                        Worksheets("汇总各表行").Cells(b + 1, 2).PasteSpecial Paste:=xlPasteFormats
                        Worksheets("汇总各表行").Cells(b + 1, 2).PasteSpecial Paste:=xlPasteValues
                        Worksheets("汇总各表行").Cells(b + 1, 1).Value = eachSheet.Name
                    End If
                Loop
                
            Else
                'MsgBox "没有找到！"
                Debug.Print "在表" & eachSheet.Name & "中" & "没有找到！"
                '如果一个也没找到，直接提示没有找到，并退出sub程序块。
                'Exit Sub
            End If
           
        End If
    Next eachSheet
End Sub

二、通过关键字查找工作表的行方法2：

Option Explicit
Option Compare Text

Sub 关键字查找工作表行2()

Dim i1, i2, i3, i4, i5, i6, b, j

Dim eachSheet, mysheet1 As Worksheet

Dim inpu As String

b = 2

On Error Resume Next '忽略运行过程中可能出现的错误

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



For Each eachSheet In Worksheets

    If Not eachSheet.Name = "汇总各表行" Then

        'Debug.Print eachSheet.UsedRange.Rows.Count, eachSheet.UsedRange.Columns.Count
        
'        For i1 = 2 To 100 '从第2行到100行
'
'            For i2 = 1 To 30 '从第二列到30列
        
        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 i3 > 0 Then '如果存在关键词，则
            
                        'eachSheet.Range(Cells(i1, 1), Cells(i1, 10)).Copy '10列
                        'columnmax =cells(i,columns.count).end(xltoleft).column   'i行的最大列数
                        
                        eachSheet.Range(Cells(i1, 1), Cells(i1, j)).Copy

                        'j = Cells(i1, Columns.Count).End(xlToLeft).Column

                        Worksheets("汇总各表行").Cells(b, 2).PasteSpecial Paste:=xlPasteFormats
                        
                        Worksheets("汇总各表行").Cells(b, 2).PasteSpecial Paste:=xlPasteValues
                        
                        Worksheets("汇总各表行").Cells(b, 1).Value = eachSheet.Name
                        
                        b = b + 1
                        
                        Debug.Print eachSheet.Name, j
                        
                        Exit For '退出For循环
                    
                    End If
                
                End If
        
            Next
        
        Next
        
     End If
     
Next

End Sub

二、通过关键字查找工作簿的行：
通过关键字查找工作簿的行，如查找关键字：合计、汇总、总计……。查找时部分匹配，不是全匹配。查找不同工作簿中的多个工作表。汇总到工作表《汇总各表行》中，保留数值、格式，不保留公式。
1、只查找包含一个关键字。

Option Explicit
Option Compare Text


Sub 关键字查找工作簿行()
    'Application.DisplayAlerts = False
    Dim i1, i2, i3, i4, i5, 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) '获取关键词所在位置
                   

                                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 & "第" & i2 & "行" & "存在查找内容。"

                                    Exit For '退出For循环

                                End If

                            End If

                        Next

                    Next

                 End If
            Next
            wkbk.Save: wkbk.Close True
        Next
    End With

    Application.DisplayAlerts = True
End Sub

2、包含一个关键字及不包含一个关键字双重条件查找。

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
weixin_46655338
关注
  • 2
    点赞
  • 踩
  • 21
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
专栏目录
用VBA查找包含某字符串的单元格并标注
02-19
怎样用VBA查找选定区域内包含某字符串的单元格，并用设定的底色显示
VBA学习笔记7：查找包含某内容的单元格
热门推荐
weixin_45355881的博客
04-21 1万+
VBA学习笔记7：查找包含某内容的单元格
【vba】【excel】找到某一个值在excel中的位置
最新发布
weixin_61256014的博客
01-31 288
Set Rng = wb.Worksheets("sheet名字").Range("D3:M20")如题，获取某一个值在excel中的所在单元格的位置，这个功能还是很常用的，代码如下。
VBA示例之 在特定的区域内查找文本,返回值是包含查找文本的单元格
10-26
VBA示例之 在特定的区域内查找文本,返回值是包含查找文本的单元格，供初学者参考，大牛勿进~~~~~~~
【VBA】在VBA内部实现高速化Vlookup检索
weixin_47527667的博客
02-25 9541
vlookup是在excel中最常使用的函数之一 但是当数据量非常大的时候 大量的vlookup会吃掉excel内存，导致文件变得很慢 下面提供一段vba的代码，让你在vba内部实行和vlookup完全一致的能力 因为使用的是在数组中比对数据的做法，计算速度会比在表内计算要提高数倍 在数据非常大量的情况下很适合使用 缺点是只能在vba内部使用，在外部不会留下函数，修改也只能在vba内部修改 以下是简单的代码外加注释说明 Function A_Vlookup() Dim Lsr As Long, SHT
Excel VBA高级编程-关键字查找数据库
Rubicon_Chen的博客
07-01 3628
这个表格的主要功能是：根据输入的关键字找到数据库中，正确的公司名，生成一个下拉菜单，再根据正确的公司名，找到对应的No生成下拉菜单 欢迎技术交流：wechat:qq-273404452 VBS 代码： Private Sub Worksheet_Change(ByVal Target As Range) Dim whereStr$, sql$, conn, mr&, j%...
Excel·VBA单元格区域获取指定行列函数
hhhhh_51的博客
06-11 7110
office 365新增函数《CHOOSEROWS 函数》和《CHOOSECOLS 函数》可以获取单元格区域指定行、列，并返回一个单元格区域对于没有office 365又想使用这个函数，就只能自己写VBA代码自定义函数了num_arr参数：正数为行从上往下、列从左往右，1为最上/最左；负数则相反，-1为最下/最右，依次类推 举例...
VBA字典按关键字提取数据
sx01117的博客
10-25 1741
VBA字典
VBA 如何实现在EXCEL多张表里搜索目标内容，并标记处 行号，列号？
奔跑的犀牛先生
01-19 804
一个VBA群里有个网友求助，我写了个试试，好像可以。。。以后在改进 Sub test_find1() Dim sh1 As Object Dim cell1 As Object Dim arr1() target1 = "A" I = 1 For Each sh1 In ThisWorkbook.Worksheets ReDim Preserve...
VBA实战(11) - 工作表(Sheet) 操作汇总
jie_ming514的博客
08-06 4722
下面案例为读取所有的 Sheet 页，检查是否有“模切绩效工资汇总表” Sheet 页。
使用 VBA 查找工作表中某个字段并返回其所在行号
QingYuanve的博客
06-15 6929
获取工作表中的第一行。然后，我们使用 Find 方法查找包含输入字段名的列，并将其索引号保存在变量 colIndex 中。的函数，该函数接受字段名和工作表名作为参数，并查找工作表中的第一行中包含输入字段名的列，并返回该字段所在的行号。) 获取这一列的范围，并使用 Find 方法查找第一个非空单元格，并将其所在的行号保存在变量。在上面的代码中，我们首先设置要查找的字段名和工作表名。在上面的代码中，我们定义了名为。函数，并将返回的结果保存到。来处理没有找到列的情况。函数在窗体中显示结果。
VBA批量查找工作簿数据.xlsm
01-07
VBA批量查找工作簿数据
VBA-拆分工作簿.xls
04-03
VBA-拆分工作簿.xls
用VBA批量转换Excel工作簿为.doc
11-18
用VBA批量转换Excel工作簿为.doc
vba案例：合并工作簿，工作表
07-26
vba案例：合并工作簿，工作表
VBA拆分工作簿.xls
01-17
VBA拆分工作簿.xls
EXCEL如何通过VBA实现合并指定工作簿
02-06
通过MultiSelect:=True参数允许同时选择多个文件，通过定义变量X，将选择的文件名（含路径赋值给X,后指定每个X1在变更集X中，）如何实现通过VBA合并多个指定工作簿到一个新的工作表或者一个工作簿的多个工作表。
合并当前目录下所有工作簿的全部工作表.xlsm
01-17
合并多个工作表的数据。在同一个文件夹里，所有的工作簿，每个工作簿的所有工作表，合并在一起。最好是格式相同的，合并在一起，效果更加好。VBA实现，办公自动化
VBA复制指定的工作表到工作簿
05-05
你可以使用以下代码将指定的工作表复制到工作簿中： ```VBA Sub CopyWorksheet() Dim wb As Workbook Dim ws As Worksheet '打开目标工作簿 Set wb = Workbooks.Open("C:\目标工作簿.xlsx") '复制指定的工作表 Set ws = ThisWorkbook.Worksheets("工作表1") ws.Copy After:=wb.Sheets(wb.Sheets.Count) '关闭目标工作簿并保存更改 wb.Close SaveChanges:=True End Sub ``` 在上面的代码中，你需要将 `"C:\目标工作簿.xlsx"` 替换为你要将工作表复制到的工作簿的路径和文件名。你还需要将 `"工作表1"` 替换为你要复制的工作表的名称。这个代码将会把指定的工作表复制到目标工作簿中，并将其插入到目标工作簿的最后一个工作表之后。最后，它将保存并关闭目标工作簿。

“相关推荐”对你有帮助么？

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值