☰

根据单元格值拆分 Excel 文件

tag-icon • tag-icon microsoft-excel
根据单元格值拆分 Excel 文件

我有一个包含超过 100000 条记录的文件。我想根据单元格值拆分文件。例如，在 AI 列中有 SOLID，我想根据 SOLID 拆分文件并以 SOLID 的名称保存。还需要拆分的每个文件中的标题。

例子

SOLID  CLIENTID   NAME    CLIENT_TYPE  STATUS
1324   123455     PU      1            3
1324   12364453   HARI    1            1
1324   4242430    S       1            1
1324   242454     SANJ    1            1
1324   454144     LOVE    1            1
1325   44         ANJ     1            1
1325   4          SUN     1            1
1325   4          ANS     1            1
1325   54546      ROBI    1            1
1289   4646       MUNI    1            1
1289   454546     JAYA    1            1
1289   46464      RAMC    1            1
1289   4545       MAHES   1            1

答案1

据我理解，您的问题，您有一个工作表，第一列包含分配给数据行的值。您想要隔离分配给每个值的行，并将每个值的行保存到单独的工作表中。考虑到您提到的重新编码次数，我假设您想避免手动执行此操作。

以下 VBA 代码可能适合您的需求。它包括一个将筛选值应用于 Excel 表并将结果保存到各个工作簿的过程，以及一个用于识别需要筛选的唯一值的实用函数。

   选项明确

   子过滤表和保存()
        '根据第一个值过滤数据范围
        ' 范围的列并保存过滤后的
        ' 值来分隔工作表。数据范围
        ' 假设从单元格 A1 开始，并且
        ' 范围第 1 行的列标题名称。
        ‘
        ' 工作簿以以下名称保存：
        ' 指定前缀并以过滤值结尾，
        例如，“FILEAcme Corporation”。
        '文件已保存，必须指定文件前缀
        ' 以下。

        Dim wb 作为工作簿
        Dim ws 作为工作表，newWs 作为工作表
        Dim tableRng 作为范围、filterValuesRng 作为范围、lastcell 作为范围
        Dim saveDir 作为字符串，savePathAndName 作为字符串
        将 msgResponse 设置为字符串，将 saveNamePrefix 设置为字符串
        Dim inputArr() 作为变量，resultArr() 作为变量
        Dim resultIndex 为 Long

        发生错误时转到 ExitErr

        附带申请
            .ScreenUpdating = False
            .启用事件 = False
        结尾

        '************************************************
        '在此设置保存目录和文件前缀
        '************************************************
        保存目录 = “e:\”
        saveNamePrefix = “文件”
        '************************************************

        设置 ws = ThisWorkbook.Worksheets("Sheet1")
        设置 lastcell = Cells.Find(What:="*", After:=[A1], _
            搜索方向:=xlPrevious)
        设置 tableRng = Range("$A$1:" & lastcell.Address)
        设置 filterValuesRng = Range("$A$2:$A$" & lastcell.Row)
        使用 ws
            出错时继续下一步 '将数据区域转换为表格
            .ListObjects.添加（源类型：=xlSrcRange，源：=tableRng，_
            XlListObjectHasHeaders:=xlYes).名称 = “主要”
            发生错误时转到 ExitErr
        结尾
        inputArr = filterValuesRng '将过滤列分配给数组
        结果Arr = GetDistinctElements（输入Arr）
        For resultIndex = LBound(resultArr) To UBound(resultArr) '循环遍历过滤器值
            使用 ws
                出错时继续下一步
                .显示所有数据
                发生错误时转到 ExitErr
                .ListObjects("主要").范围.自动过滤 _
                    Field:=1, Criteria1:="=" & resultArr(resultIndex) '设置当前过滤值
                .ListObjects("Main").Range.Copy '复制已筛选的行
            结尾
            设置 newWs = Workbooks.Add(xlWBATWorksheet).Worksheets(1) '创建新工作簿并
            出错时继续下一步'将筛选出的行粘贴到其中
            使用 newWs.Range("A1")
                .PasteSpecial xlPasteColumnWidths
                .PasteSpecial xlPasteValuesAndNumberFormats
                。选择
                应用程序.CutCopyMode = False
            结尾
            发生错误时转到 ExitErr
            设置 wb = ActiveWorkbook '文件保存例程
            保存路径和名称 = 保存目录 & 保存名称前缀 & _
                              resultArr(resultIndex) & ".xlsx"
            如果 Dir(savePathAndName) = "" 那么
                wb.SaveAs 保存路径和名称
                wb.关闭
            否则'处理现有文件（如果有）
                msgResponse = MsgBox("文件" & saveNamePrefix & _
                              结果Arr(结果索引) & _
                              “.xlsx 已存在。”& vbCrLf & _
                              “替换现有文件？”，_
                              vbYesNo取消)
                如果 msgResponse = vbYes 那么
                    应用程序.DisplayAlerts = False
                    wb.SaveAs 保存路径和名称
                    wb.关闭
                    应用程序.DisplayAlerts = True
                别的
                    应用程序.DisplayAlerts = False
                    wb.关闭
                    应用程序.DisplayAlerts = False
                万一
            万一
        下一个结果索引
        ws.ShowAllData '将数据表转换回范围
        ws.ListObjects("Main").Unlist '并删除格式
        使用 tableRng
            .边框（xlEdgeLeft）。线条样式 = xlNone
            .边框（xlEdgeTop）.LineStyle = xlNone
            .边框（xlEdgeBottom）.LineStyle = xlNone
            .边框（xlEdgeRight）.线条样式 = xlNone
            .边框（xlInsideVertical）。线条样式 = xlNone
            .边框（xlInsideHorizo​​ntal）.线条样式 = xlNone
            .字体.粗体 = False
            使用 .Interior
                .模式 = xlNone
                .色调和阴影 = 0
                .图案色调和阴影 = 0
            结尾
        结尾
        ws.Range("A1").选择
        退出子程序

    退出错误：
        附带申请
            .屏幕更新 = True
            .启用事件 = True
            .DisplayAlerts = True
        结尾
        设置 ws = Nothing
        设置 newWs = Nothing
        MsgBox “错误”＆Err.Number＆“：”＆Err.Description，vbOKOnly，“错误”
    子目录结束

    函数 GetDistinctElements(ByRef inputArr)
        '从 N×2 数组中返回唯一项的一维数组
        '输入包含重复项的数据项数组。
        ' 输入数组通常由
        ' 将单列工作表范围分配给
        ' 变量数组。

        Dim dict 作为对象
        暗淡如长
        设置 dict = CreateObject("Scripting.Dictionary")
        对于 i = LBound(inputArr) 到 UBound(inputArr)
            字典（输入数组（i，1））= 1
        接下来我
        获取不同元素 = 字典.Keys()

    结束函数

相关内容