Excel VBA工作薄 5.10只合并含有某关键字的工作薄 数据汇总更精确

前景提要

最近在讨论工作薄汇总和合并数据方面的问题，各种反馈也是比较的多，最近有小伙伴们表示他们再汇总数据的时候，并不需要将文件夹内的所有的工作薄都汇总，他们需要的是按照工作薄名字的关键自来汇总，比方说****商城，****分店这样的模式，其他的并不包含这些关键字段的工作薄就不需要汇总了，好像这样的场景比较常用在各分店，店铺统计销售量的时候使用，既然大家有需要，小编就来分享下这个问题的解法

场景模拟

我们用之前模拟过的各商城的数据来模拟下场景，假设我们需要汇总当前香港地区的产品的销量，但是香港地区的产品销量分布在两个表格中，一个是香港，一个是港台，其他的工作薄的数据和我们就没有任何的关系了，我们只需要汇总这两个工作薄的数据，那么我们来尝试下，如何实现

image.png

image.png

方法分析

从案例中来看，两个表的数据和字段并不相同，姓名不同，字段顺序和字段内容都不相同，这个我们在之前学习过了如何实现了，用数组的方法就可以了，我们今天还有一个关键点，判断工作薄的名字中是否含有关键字，在之前我们学习过判断字符串中是否含有某字符，我们可以使用like()函数来实现，那么关键字从何而来呢，当然是通过输入的方式来得到咯，inputbox()，又是我们前面学习过的知识点，那么方法都有了，我们动手吧

代码区

Sub 工作薄名字中含有关键字()

Dim arrT()

Set sbook = ActiveWorkbook

GuanJian = Application.InputBox("请输入关键字", "关键字的确认", , , , , , 3)

With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show = -1 Then

        pathn = .SelectedItems(1)

    End If

    f = Dir(pathn & "\")

    Do While f <> ""

        If f Like "*" & GuanJian & "*" Then

        l = Cells(Rows.Count, 1).End(xlUp).Row

        k = k + 1

                If k = 1 Then

                    Workbooks.Open (pathn & "\" & f)

                    Set rng = ActiveSheet.UsedRange

                    rng.Copy sbook.Worksheets(1).Cells(1, 1)

                    Else

                        l1 = Cells(1, Columns.Count).End(xlToLeft).Column

                        arrT = Range(Cells(1, 1), Cells(1, l1))

                        Workbooks.Open (pathn & "\" & f)

                        Set rng = ActiveSheet.UsedRange

                        arrW = rng.Rows(1)

                        l2 = UBound(arrW, 2)

                        For i = 1 To l2

                            On Error Resume Next

                            num = WorksheetFunction.Match(arrW(1, i), arrT, 0)

                            If Err.Number = 0 Then

                                rng.Columns(i).Offset(1, 0).Copy sbook.Worksheets(1).Cells(l + 1, num)

                                Else

                                    l3 = sbook.Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column

                                    sbook.Worksheets(1).Columns(l3).Insert

                                    sbook.Worksheets(1).Cells(1, l3) = arrW(1, i)

                                    rng.Columns(i).Offset(1, 0).Copy sbook.Worksheets(1).Cells(l + 1, l3)

                                    ReDim Preserve arrT(1 To 1, 1 To l3 + 1)

                                    arrT(1, l3) = arrW(1, i)

                                    arrT(1, l3 + 1) = arrW(1, l2)

                            End If

                        Next i

                End If

            ActiveWorkbook.Close True

        End If

        f = Dir()

    Loop

End With

End Sub

我们来看看最终的效果

image.png

仅仅是合并了我们需要合并的两个工作薄的数据，其他的工作薄数据并没有汇总，这样得到的数据更加的精确