精华内容
下载资源
问答
  • 在多个工作簿中查找
    2022-05-31 20:01:37
    SUB SplitRange
        '关闭屏幕刷新
    	Application.ScreenUpdating = FALSE
    	'禁用事件
    	Application.EnableEvents = FALSE
    	'禁止显示提示和警告消息
    	Application.DisplayAlerts = FALSE
    	ThisWorkbook.Worksheets("清单").SELECT
    	'声明字符串类型的数组
    	DIM STR() AS STRING
    	DIM STR1() AS STRING
    	'获取当前工作簿中”清单“工作表的第二列的行数
    	lastrow = ThisWorkbook.Worksheets("清单").CELLS(ROWS.COUNT,2).END(XLUP).ROW
    	'从第三行开始循环
    	FOR i = 3 TO lastrow
    	
    		workbookName = ThisWorkbook.Worksheets("清单").CELLS(i,8).VALUE
    		'打开工作簿
    		Workbooks.OPEN (workbookName)
    		
    		lastrow1 = Workbooks(workbookName).Worksheets("清单").CELLS(ROWS.COUNT,2).END(XLUP).ROW
    		
    		
    		'循环工作簿所有工作表 FOR EACH SH IN Workbooks(workbookName).Worksheets
    		'工作表不隐藏以及工作表名不为“ATTU“ IF SH.VISIBLE = TRUE AND SH.NAME <> "ATTU" THEN
    		FOR j = 3 TO lastrow1
    			sheetname1 = Workbooks(workbookName).Worksheets("清单").CELLS(j,7).VALUE
    			sheetname2 = Workbooks(workbookName).Worksheets("清单").CELLS(j,7).VALUE
    			
    			lastrow2 = Workbooks(workbookName).Worksheets(sheetname1).CELLS(ROWS.COUNT,2).END(XLUP).ROW
    			
    			M = 1
    			'清空部分单元格内容 Clear/Delete/ClearContents
    			ThisWorkbook.Worksheets("统计").RANGE("A:C").Clear
    			FOR k = 5 TO lastrow2
    				XUHAO = Workbooks(workbookName).Worksheets(sheetname1).CELLS(k,2).VALUE)
    				Q = ""
    				'将内容中的回车符替换为换行符
    				Strg = REPLACE(Workbooks(workbookName).Worksheets(sheetname1).CELLS(k,7).VALUE,CHR(13),CHR(10))
    				IF Strg = "" THEN 
    					WW = 1
    				ELSE
    				    '对字符串进行分割,分割符为换行符
    					STR() = SPLIT(Strg,CHR(10))
    					'获取数组的边界
    					J1 = UBOUND(STR)
    					
    					FOR l = 0 J1
    					    '对数组的内容去除空格处理
    						A = TRIM(STR(l)
    						Q = " : " & A
    						W = REPLACE(Q," : ","")
    						'对字符串进行大写处理
    						ThisWorkbook.Worksheets("统计").CELLS(M,1)=UCASE(W)
    						
    						M = M + 1
    					NEXT
    				END IF
    				
    			NEXT
    			'以第二行第一列为起始位置,扩展1行200列,查找”备注“单元格的列数
    			'MATCHCASE区分大小写属性,false为不区分,默认为false
    			R1 = Workbooks(workbookName).Worksheets(sheetname1).CELLS(2,1).RESIZE(1,200).FIND("备注",MATCHCASE:=FALSE).COLUMN
    			'LOOKAT是是否完全匹配单元格内容属性,XLWHOLE为完全匹配,默认部分匹配
    			SET RNG1 = ThisWorkbook.Worksheets("统计").CELLS(1,1).RESIZE(10000,3).FIND("SJAJHDD",LOOKAT:=XLWHOLE)
    			
    			IF RNG1 IS NOTHING THEN
    				DD = 1
    			ELSE 
    				ThisWorkbook.Worksheets("统计").CELLS(1,10) = "QQQQ"
    			END IF
    		NEXT
    		'工作簿保存
    		Workbooks(workbookName).SAVE
    		'工作簿关闭
    		Workbooks(workbookName).CLOSE
    		
    	NEXT
    	
    	
    	ThisWorkbook.Worksheets("清单").SELECT
    	Application.EnableEvents = FALSE
    	Application.ScreenUpdating = FALSE
    	
    	MSGBOX "复制分割完成" & VBLF & DD , VBINFORMATION,"友情提示"
    	
    END SUB
    
    更多相关内容
  • VBA示例函数之 求人不如自已动手 多个工作表中查找一个范围内符合某个指定条件的项目对应指定范围加总求和 ,供初学者参考,大牛勿进~~~~~~~
  • excel多工作簿多工作表数据查询,有三种方法,可自行选择
  • Excel中多个工作簿快速合并,系统导出的多个工作簿,快速合并,方便统计、打印、查找……等等
  • 示例 如图所示,同一个目录下有多个工作表名称相同的工资汇总月报。现希望通过VBA建立该多个月份的月报总表,将多个工作簿中的“工资汇总”工作表导入当前工作簿,并以月份命名。该如何实现呢? ...

    目录

    示例

    实现代码

    导入多个工作簿中的工作表

     Application. ScreenUpdating属性


    示例

        如图所示,在同一个目录下有多个工作表名称相同的工资汇总月报。现希望通过VBA建立该多个月份的月报总表,将多个工作簿中的“工资汇总”工作表导入当前工作簿,并以月份命名。该如何实现呢?

    实现代码

    Option Explicit
    
    Sub 批量导入工作表()
        Dim FileName As String
        Dim FilePath As String
        Dim wbkThis As Workbook
        Dim wbkOpen As Workbook
        Dim shtNew As Worksheet
        Dim shtData As Worksheet
        
        '禁止屏幕刷新
        Application.ScreenUpdating = False
        '设置当前工作薄
        Set wbkThis = ThisWorkbook
        '关闭警告
        Application.DisplayAlerts = False
        '删除当前工作薄中除Sheet1外的所有工作表
        For Each shtNew In wbkThis.Worksheets
            If shtNew.Name <> Sheet1.Name Then
                shtNew.Delete
            End If
        Next
        '打开警告
        Application.DisplayAlerts = True
        '获取当前工作薄路径
        FilePath = wbkThis.Path
        '查找工作薄
        FileName = Dir(FilePath & "\*.xlsm")
        '当查找结果不为空时循环
        Do While FileName <> ""
            '打开工作薄
            Set wbkOpen = Workbooks.Open(FilePath & "\" & FileName)
            '设置源数据工作表
            Set shtData = wbkOpen.Worksheets(1)
            '当前工作薄中插入工作表
            Set shtNew = wbkThis.Worksheets.Add(after:=wbkThis.Worksheets(wbkThis.Worksheets.Count))
            '更改工作表名称
            shtNew.Name = Left(FileName, Len(FileName) - 5)
            '复制源数据至新工作表
            shtData.Cells.Copy shtNew.Range("A1")
            '关闭工作簿
            wbkOpen.Close False
            '查找下一个工作薄
            FileName = Dir
        Loop
        '启用屏幕刷新
        Application.ScreenUpdating = True
    End Sub
    

    导入多个工作簿中的工作表

        导入多个工作簿中的工作表时,一般先将工作簿打开,然后将工作簿中指定的工作表复制到当前工作簿中。当打开工作簿时,有以下两种常用的方法对数据进行进一步处理。

    • 使用Copy方法将工作簿中所需的工作表逐一复制到当前工作簿中,然后进行集中处理。
    • 直接插入工作表,然后将指定工作簿中工作表的内容进行复制。

        本例采用了第2种方法:使用Dir函数查找当前工作簿所在目录中的文件,并逐一打开。当打开工作簿后,插入一个工作表并读取工作簿中的“工资汇总”表。在该处理过程中,必须使用单元格的完整表述,否则将造成错误。

     Application. ScreenUpdating属性

        VBA程序在执行过程中,当程序对工作表和单元格进行反复操作时,用户可以看见程序在不断地打开工作表,并对工作表和单元格进行操作。而当大量的操作在进行时,不但会降低程
    序运行的速度,还会因此造成不断闪屏。
        为解决这一问题,可以将Excel对象(Application)的ScreenUpdating属性设置为False。该属性表示是否刷新屏幕,若将该属性设置为False,则在运行程序时,用户将看到运行程序前最后的画面,直到程序运行完毕。但在程序结束前,应将该属性再次设定为True,允许屏幕刷新,则不会影响用户的正常操作。
     

    展开全文
  • excelvba下的代码,合并当前文件夹下所有excel工作表到一新建的工作表中,并将合并的数据进行横向铺开排列。
  • 查找不同工作簿中多个工作表。汇总到工作表《汇总各表行》,保留数值、格式,不保留公式。 Option Explicit Option Compare Text Sub 关键字查找工作簿行() 'Application.DisplayAlerts = False Dim i1, i2, ...

    一、通过关键字查找工作表的行方法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
    
    展开全文
  • 多个excel自动合并到同一表格,该段vba代码的逐句拆解

    目录

    一、总说明

    1 当前需求

    2 操作和注意点

    3 运行代码

    二、代码逐句拆解 - 前

    1 Sub&End Sub

    2 Dim As

    3 关闭屏幕自动刷新

    4  MyPath = ActiveWorkbook.Path 

    ①  拆解 ActiveWorkbook.Path   

    ② 拆解 MyName = Dir(MyPath & "" & "*.xlsx") 

    ③AWbName = ActiveWorkbook.Name

    三、代码逐句拆解 - 中

    1  Num = 0 和 Num = Num + 1

    2 Do While 

    3  IF   Then ; Workbooks.Open( )

    4   With Workbooks(1).ActiveSheet

    5 选取表内所有单元格

    四、代码逐句拆解 - 后

    1 WbN = WbN & Chr(13) & Wb.Name

    2 Wb.Close False

    3 MyName = Dir

    4 LOOP

    5 选中单元格

    6 MsgBox 


    一、总说明

    1 当前需求

    需要将多个excel表格里的内容,合并到同一个表格里,每个待合并的表格列项相同,行内容不同。

    2 操作和注意点

    操作:将所有待合并的excel表格,放到同一文件夹里 → 仅打开一个xlsm表,作为运行操作,待合并的表格不打开 → 开发工具 - 宏 → 输入运行代码 → 运行

    注意点:

    • 运行的宏文件格式另存为 .xlsm
    • excel表格内仅保留需要合并的内容,注意待合并的表格,有无隐藏的sheet,运行前要删除。因为宏运行时,会自动把隐藏的表格一起合并
    • 合并表格仅合并筛选出来的单元格,所以合并前可以先检查一下,要合并的表格有无筛选或隐藏

    3 运行代码

    总运行代码如下,可直接复制到 宏,保存并运行即可  

    Sub 合并当前目录下所有工作簿的全部工作表()
     
    Dim MyPath, MyName, AWbName
     
    Dim Wb As Workbook, WbN As String
     
    Dim G As Long
     
    Dim Num As Long
     
    Dim BOX As String
     
     
     
    Application.ScreenUpdating = False
     
    MyPath = ActiveWorkbook.Path
     
    MyName = Dir(MyPath & "\" & "*.xlsx")
     
    AWbName = ActiveWorkbook.Name
     
    Num = 0
     
    Do While MyName <> ""
     
    If MyName <> AWbName Then
     
    Set Wb = Workbooks.Open(MyPath & "\" & MyName)
     
    Num = Num + 1
     
    With Workbooks(1).ActiveSheet
     
    .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
     
    For G = 1 To Sheets.Count
     
    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
     
    Next
     
    WbN = WbN & Chr(13) & Wb.Name
     
    Wb.Close False
     
    End With
     
    End If
     
    MyName = Dir
     
    Loop
     
    Range("B1").Select
     
    Application.ScreenUpdating = True
     
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" 
    & Chr(13) & WbN, vbInformation, "提示"
     
     
     
    End Sub
    

    二、代码逐句拆解 - 前

    引用语句的前部如下:

    Sub 合并当前目录下所有工作簿的全部工作表()
     
    Dim MyPath, MyName, AWbName
     
    Dim Wb As Workbook, WbN As String
     
    Dim G As Long
     
    Dim Num As Long
     
    Dim BOX As String

    Application.ScreenUpdating = False
     
    MyPath = ActiveWorkbook.Path
     
    MyName = Dir(MyPath & "\" & "*.xlsx")
     
    AWbName = ActiveWorkbook.Name

    1 Sub&End Sub

    • 表示一个宏过程的开头,后面跟的是该宏的命名名称。End Sub表示一个宏过程的结束。两者对应出现,分别在宏的最开头和最结尾的位置。
    • 引用上述代码部分:

    Sub 合并当前目录下所有工作簿的全部工作表()

    End Sub

    2 Dim As

    引用上述代码如下,即声明Wb作为一个工作簿对象,WbN为字符型;声明G、NuM为长整数型;声明BOX为字符型:

    Dim MyPath, MyName, AWbName
     
    Dim Wb As Workbook, WbN As String
     
    Dim G As Long
     
    Dim
    Num As Long
     
    Dim BOX As String

    • Dim即声明,用于定义变量,以此设定各个变量的类别。
    • 形式为:dim + 变量名 + as + 数据类型 
    名称类型字节大小包含的数据及范围

    Integer

    整数型2-32768到32767的整数
    Long长整数型4-2147483648到2147483647的整数
    Byte字节型10到255的整数
    Date日期型8100年1月1日到9999年12月31日
    String字符型0-6553个字符
    Object对象型4任何对象引用
    Boolean布尔型只有两个值True/-1,或False/0
    workbook工作簿


     

    3 关闭屏幕自动刷新

     用于关闭程序运行时,屏幕的不断刷新。

    • 可在dim声明后,可在程序开始之前,输入 Application.ScreenUpdating = False
    • 在end sub以前,即程序运行的最后,不再出现屏幕刷新的位置,输入 excel.Applicantion.ScreenUpdating = TRUE

    引用代码部分如下:

    Application.ScreenUpdating = False
               
          ···

    Application.ScreenUpdating = True

    4  MyPath = ActiveWorkbook.Path 

    引用上述代码如下:

    MyPath = ActiveWorkbook.Path
     
    MyName = Dir(MyPath & "\" & "*.xlsx")
     
    AWbName = ActiveWorkbook.Name

    ①  拆解 ActiveWorkbook.Path   

    • ACTIVE当前的,活动的
    • workbook 工作薄
    • path 路径

    即当前(选择的、使用的、激活的)的工作簿的路径

    ② 拆解 MyName = Dir(MyPath & "" & "*.xlsx") 

    说明:Dir函数的作用是返回目录下的指定文件名称,即该行引用语句为查找该目录下格式为xlsx的当前第一个activeworkbook,令Myname为当前的第一个文件名。若第二次调用 Dir 函数,但不带任何参数,则函数将返回同一目录下的下一个 *.xlsx文件。

    表现形式:Dir (pathname,  attributes)

    • pathname:用来指定文件名的字符串表达式。可以包含目录、文件夹或驱动器。如未设置 pathname,则会返回零长度字符串 ("")。
    • attributes :用来指定文件属性。如省略了后半段的attributes,则返回匹配 pathname,但不包含属性的文件。

    e.g1. 返回当前文件夹中,第一个属性为TEXT的文件名称:

             = Dir ( "SomePath", MacID("TEXT") )

    e.g2. 为选中文件夹中所有文件,指定一空串:

             = Dir("")


    ③AWbName = ActiveWorkbook.Name

      令当前活动的工作簿名,赋名为awbname

    三、代码逐句拆解 - 中

    引用语句的中部如下:

    Num = 0
     
    Do While MyName <> ""
     
    IF MyName <> AWbName Then
     
    Set Wb = Workbooks.Open( MyPath & "" & MyName )
     
    Num = Num + 1
     
    With Workbooks(1).ActiveSheet
     
    .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)


    For G = 1 To Sheets.Count
     
    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)

    NEXT

    1  Num = 0 和 Num = Num + 1

    • Num = 0:设定FOR循环的初始值,说明初始化的num值从0开始
    • Num = Num + 1:设置此处开始num=num+1,即运行次数+1

    2 Do While 

    do while 循环可视为 while 循环的前奏。在检查while()条件是否为真前,该循环会先执行一次do语句。如条件为真,则会重复do while循环,直到while后跟的条件为假。

    Do While MyName <> " "

    该语句表示:当条件 MyName 不等于 空值,则往下执行循环操作,也就是当指定路径中有文件时,进行循环。

    3  IF   Then ; Workbooks.Open( )

    IF MyName <> AWbName Then Set Wb = Workbooks.Open( MyPath & "" & MyName )

    如果 MyName 不等于 AWbName  打开符合条件的文件,赋名其为WB

    包含语句如下:条件语句     IF THEN   

                             打开工作簿  Workbooks.Open()

    4   With Workbooks(1).ActiveSheet

    • 作用于 工作簿 (1) 的活动工作表。
    • WITH的作用是 简化代码输入,省略前面的所有赋值。
    • WITH 结束后的字节加上 END WITH

    5 选取/复制表内所有单元格

    .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)

                                                  ....

    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)

    第一句表示:选取在当前工作薄中的B列,该列的最后非空单元格后2格,加上合并文件名,且不包含扩展名(合并的最大行数为65536)。逐步拆解如下:

    • Range("B65536").End(xlUp).Row   为返回B列数据区域最后一行的行号,相当于在B65536按CTRL+↑后,选中的那个单元格的行号。如A999是空单元格,A1000:A65536都有数据,那么这段代码得到的行号就会是1000。
    • .Cells( )  cells 即单元格,函数用于读取单元格内容,将内容写入单元格。cells(1,1)代表第一行第一列,也就是A1单元格,与Range("A1")所指一样
    • End(xlUp):向上查找
    • Left(MyName, Len(MyName) - 4)   和excel使用的left、len函数作用一样。从左开始提取字节,提取到字符长度的倒数第4个字符结束。

    第二句表示:复制所有sheet的单元格

    • UsedRange.Copy:   UsedRange表示属性,指工作表中已使用过的单元格区域。和COPY组合使用,即复制已使用过的单元格。

    6 For G = 1 To Sheets.Count

    • 从1开始,选取到所有sheet的总数
    • Sheets.Count表示所有sheet的合计数

    四、代码逐句拆解 - 后

    引用语句的尾部如下:

    WbN = WbN & Chr(13) & Wb.Name
    Wb.Close False
    End With
    End If
     
    MyName = Dir
     
    Loop
    Range("B1").Select
    Application.ScreenUpdating = True
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" 
    & Chr(13) & WbN, vbInformation, "提示"
      
    End Sub

    1 WbN = WbN & Chr(13) & Wb.Name

    • 即 把当前所有的工作簿名称另起一行,放入字符串WbN中。工作簿名称字符串(wbn)=原工作簿名称集合(wbn)+回车(chr(13))+新工作簿名称(wb.name)
    • chr(13)字符表示回车键,整合chr含义如下:
      chr(13)回车
      chr(10)换行
      chr(32)空格
      chr(9)tab

    2 Wb.Close False

    该语句用于保存运行过的Excel文件时,不弹出是否保存的提示框。

    3 MyName = Dir

    • 如上,Dir 函数来检查某些文件或目录是否存在。
    • 因为是第二次调用 Dir 函数,所以不用带任何参数,该语句会返回同目录下的下一个 *.xlsx 文件。

    4 LOOP

    do while...loop:和上述的 do while 联合使用,类型if语句,loop放在循环的结尾处。

    5 选中单元格

    Range("B1").Select

    即选中B1这个单元格

    6 MsgBox 

    该语句的作用为弹出一个对话框,对话框内容为“共合并了num个工作簿下的全部工作表内容。如下:”

    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" 
    & Chr(13) & WbN, vbInformation, "提示"

    • MsgBox 即弹出对话框。形式如下:MsgBox "内容" , 参数 , "标题"
    • vbInformation 是msgbox的参数,显示 Information Message 图标。作用是使对话框上显示信息的图标,并且只有确定的按钮。

    P.S.可算是敲完啦!4578个字!以上就是整合的该段代码全部含义。

    展开全文
  • 如何在多个EXCEL文件搜索某一内容,并展示出查找内容所在的行,所在的文件、所在信息。 日常办公,经常从面临多个Excel文件查找出需要的信息。对于复杂的信息有时候也需要支持正则表达式的查找。今天介绍...
  • 1.父目录查找处输入关键词 2.将找到的文件进去查找-工作簿
  • wps表格怎么多个工作表检索内容?

    千次阅读 2020-05-29 11:04:45
    1.准备工作 2.Ctrl+F 调出查询界面 3.查询结果
  • 2、单个值填充演变到多个值 单个值填充完之后,把鼠标放到公式所在单元格的右下角,会出现“+”号,双击“+”号即可自动填充下面所有要查找的值(前提:设置数据源阶段,要选中全部数据及公式的修改(有些是...
  • 使用VBA代码操作工作表时,如果...代码这样用到此功能,那么将可以将此功能封装为一自定义函数,代码可以很方便的调用函数。 方法1:遍历表对象 Function blnSheetExist1(ByVal strSheetName As Strin...
  • 虽然我是一程序员,但是最近总是有同事问我关于打印或者WPS相关的问题,保存文件时出现“您选定的文件类型不支持包含工作表工作簿。”
  • 我有100个excel文件,一个目录下,如何另外的excel文件中查找数据 举思路:先把另外99个workbook合并到一个book,然后用vlookup查找即可。...如何快速搜索多个word,excel等文件内容快速搜索多个word、...
  • EXCEL使用vlookup函数合并多个工作表

    千次阅读 2021-03-17 21:34:52
    EXCEL使用vlookup函数合并多个工作表 vlookup函数功能比较强大,不仅可以同一个表格进行使用,还可以对两个不同的表格进行匹配查找。可以进行两个表的合并。 例: 表1 软件工程学生信息表 表2 计算机学院学生...
  • 有时我们可能会两种工作表中查找重复记录,当数据记录很时,就必须通过简单的方法来实现。下面小编就与大家一起分享一下查看重复记录数据的方法,希望对大家有所帮助。 方法/步骤   为了...
  • excelvlookup 从另一个工作簿中的Excel VLOOKUP (Excel VLOOKUP From Another Workbook) If you're filling in an order form in Excel, you can use the VLOOKUP function to find the selling price for each ...
  • Python办公自动化实践1:从多个excel表提取数据并汇总到一个工作表,表格,抽取,sheet 发表时间:2020-04-26 问题:从当前目录或子目录查询符合条件的excel表格,并从这些excel表格抽取符合条件的行汇总到...
  • 工作,我们有时会需要将多个工作表Sheet的名称提取出来,制作成一个目录 如果一个一个去复制粘贴,效率肯定是很低的,如果Sheet数量很多,会严重影响我们的工作进度,那该如何处理呢?我们可以用VBA的方法快速处理...
  • 工作表的一区域有很值,我们很容易用min或者max函数找出这区域的最小值或者最大值,但是,要确定这值的位置就比较难了,因为match函数或者vlookup(或者hlookup)函数都是对单行或者单列进行操作的。...
  • 通过excel宏工具,快速实现多个excel工作簿数据合并功能。适用于工作模板下发填报后一键汇总生成总。 内附参考实例,以及vb代码。
  • 有两 表格 sheet1 和 sheet2 ,AB 两列 ,sku和仓库 两条件确定一条记录,现在是 sheet1 的数据比sheet2 数据 ,如何查找出 存在与 sheet1 ,但是不 sheet2 的数据 ?   附公式: Sub 数据...
  • 数据:N张工作簿,每张工作簿里又有M张工作表,每张工作表的同一位置Cells(2,16)有需要的数据,想讲这些数据汇总到一张新的表格。 新建一张“汇总.xlsm”,并打开,新建sub()过程; 依次打开工作簿; 源码如下: ...
  • 如何EXCEL建立一个超链接,点击它后可以显示另一指定工作表中经过筛选的多个行。1、电脑打Excel格,进入工作表2,把进行筛选好。2、表格1,选中格然后点击右键选择链接。3、点击后,选择本文档的位置,...
  • 怎么excel利用vlookup函数进行信息查找随着科技的发展,电脑已经越来越完善,电脑的软件也成为了人们解决日常问题的主要工具。当我们使用excel处理数据时,该如何使用vlookup函数查找信息呢?接下来就由小编...
  • 如何使用VLOOKUP函数查找引用其他工作表数据和自动填充数据
  • VLOOKUP函数查找两个工作表的重复数据 第一次用到这个函数还是好几年以前,有个学生家长问我,如果两个工作表里有部分重复的数据,怎么才能找出来?当然这两个工作表的数据都很,所以人工检索的话工作量...
  • 一、批量新建并保存工作簿
  • 这里整合指把Sheet移动到一workbook。没有覆盖到子文件夹的文件。Sub Test() Debug.Print (ThisWorkbook.Path) Dim p, stockcode As String Dim f p = ThisWorkbook.Path &amp; "\" f = Dir...

空空如也

空空如也

1 2 3 4 5 ... 20
收藏数 515,564
精华内容 206,225
关键字:

在多个工作簿中查找