中的inputbox_Excel中按列拆分万条数据，用这串代码可以一键搞定，收藏备用

先来看看问题

如图，表中保存了许多数据，现需要按A列日期拆分到不同的工作簿中。

图1 待拆分的数据

图2 拆分所得的工作簿

图3 拆分所得工作簿中的数据

解决办法

步骤1：在工作簿中按打开VBE窗口，在VBE窗口中插入一个模块。

图4 插入模块

步骤2：在插入的模块中写入下面的代码。

Sub 拆分数据到工作簿()    Application.ScreenUpdating = False    Dim Dic As Object, Irow As Long, i As Long, ToFolder As String    Set Dic = CreateObject("Scripting.Dictionary")    Irow = ActiveSheet.UsedRange.Rows.Count    ToFolder = ThisWorkbook.Path & "拆分结果"    If Len(Dir(ToFolder, vbDirectory)) = 0 Then MkDir ToFolder    Dim DateSht As Worksheet, ToSht As Worksheet, arr As Variant, Icol As Long, Cel As Range    Set DateSht = ActiveSheet    On Error GoTo er:    Set Cel = Application.InputBox(prompt:="要按哪列的信息拆分数据？请选择该列的任意一个单元格：", Title:="设置", Type:=8)    Icol = Cel.Cells(1).Column    On Error GoTo 0    For i = 2 To Irow        Dic(DateSht.Cells(i, Icol).Value) = DateSht.Cells(i, Icol).Value    Next i    DateSht.Cells(1, "XFD").Value = DateSht.Cells(1, Icol).Value    arr = Dic.keys    For i = 0 To Dic.Count - 1        DateSht.Cells(2, "XFD").Value = arr(i)        Worksheets.Add.Name = arr(i)        Set ToSht = ActiveSheet        DateSht.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=DateSht.Range("XFD1:XFD2"), CopyToRange:=ToSht.Range("A1")        ToSht.Cells.EntireColumn.AutoFit        ToSht.Move        ActiveWorkbook.SaveAs Filename:=ToFolder & "" & arr(i) & ".xlsx"        ActiveWorkbook.Close    Next i    DateSht.Columns("XFD:XFD").Delete    Application.ScreenUpdating = True    MsgBox "数据拆分完成,单击【确定】查看拆分结果。", vbInformation    Shell "explorer.exe " & ToFolder & "", vbNormalFocuser:End Sub

图5 写入的代码

步骤3：返回Excel界面，执行这个过程，就能自动完成数据拆分任务了。

图5 执行代码拆分数据

我是叶枫，感谢你的阅读。

点击下面的“了解更多”可以观看演示视频。