文章摘要
这篇文章介绍了使用VBA编写的一个小型程序,旨在将数据按指定列号拆分成多个Excel文件。代码首先从输入框获取拆分列号,然后通过循环处理数据,构建一个字典来合并重复项。随后,程序将处理后的数据复制到新的工作簿中,并为每个列号生成一个独立的Excel文件。最终,程序会显示一个消息通知任务完成。
? Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
? c=Application.InputBox(“请输入拆分列号”, , 4, , , , , 1)
? If c=0 Then Exit Sub
? Application.ScreenUpdating=False
? Application.DisplayAlerts=False
? arr=[a1].CurrentRegion
? lc=UBound(arr, 2)
? Set rng=[a1].Resize(, lc)
? Set d=CreateObject(“scripting.dictionary”)
? For i=2 To UBound(arr)
? If Not d.Exists(arr(i, c)) Then
? Set d(arr(i, c))=Cells(i, 1).Resize(1, lc)
? Else
? Set d(arr(i, c))=Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
? End If
? Next
? k=d.Keys
? t=d.Items
? For i=0 To d.Count – 1
? With Workbooks.Add(xlWBATWorksheet)
? rng.Copy .Sheets(1).[a1]
? t(i).Copy .Sheets(1).[a2]
? .SaveAs Filename:=ThisWorkbook.Path & “” & k(i) & “.xls”
? .Close
? End With
? Next
? Application.DisplayAlerts=True
? Application.ScreenUpdating=True
? MsgBox “完毕”
End Sub
? c=Application.InputBox(“请输入拆分列号”, , 4, , , , , 1)
? If c=0 Then Exit Sub
? Application.ScreenUpdating=False
? Application.DisplayAlerts=False
? arr=[a1].CurrentRegion
? lc=UBound(arr, 2)
? Set rng=[a1].Resize(, lc)
? Set d=CreateObject(“scripting.dictionary”)
? For i=2 To UBound(arr)
? If Not d.Exists(arr(i, c)) Then
? Set d(arr(i, c))=Cells(i, 1).Resize(1, lc)
? Else
? Set d(arr(i, c))=Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
? End If
? Next
? k=d.Keys
? t=d.Items
? For i=0 To d.Count – 1
? With Workbooks.Add(xlWBATWorksheet)
? rng.Copy .Sheets(1).[a1]
? t(i).Copy .Sheets(1).[a2]
? .SaveAs Filename:=ThisWorkbook.Path & “” & k(i) & “.xls”
? .Close
? End With
? Next
? Application.DisplayAlerts=True
? Application.ScreenUpdating=True
? MsgBox “完毕”
End Sub
© 版权声明
文章版权归作者所有,未经允许请勿转载。


