【VBA修改】excel按照某一列内容保留表头和结尾拆分为独立的新表

2 篇文章 0 订阅

Sub 保留表头拆分数据为若干新工作簿()
    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(6, lc)                                  '本句代码中,偏移行的多少决定保留表头的行数,你要保留7行,就可以将6改为7即可。
    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).[a7]                         '这句中A列数字为几,则拆分后的数据在A列第几行,需要比前面红色注明的数字大1。
            .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
            .Close
        End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

  • 2
    点赞
  • 13
    收藏
    觉得还不错? 一键收藏
  • 3
    评论
Excel VBA中,可以使用类似Python的方式将数组按照首列所含项目拆分为多行,并按照要求进行排序。以下是示例代码: ```vb Sub SplitAndSortData() ' 原始数据 Dim data As Variant data = Array("banana;apple;pear" & vbTab & "10" & vbTab & "20" & vbTab & "30", _ "banana" & vbTab & "20" & vbTab & "30" & vbTab & "40", _ "orange;banana" & vbTab & "15" & vbTab & "25" & vbTab & "35", _ "apple" & vbTab & "25" & vbTab & "35" & vbTab & "45") ' 拆分为多行 Dim new_data As Variant ReDim new_data(1 To 1, 1 To UBound(data) * 3) Dim i As Long, j As Long, k As Long For i = 0 To UBound(data) Dim items As Variant items = Split(data(i), vbTab) Dim first_col_items As Variant first_col_items = Split(items(0), ";") For j = 0 To UBound(first_col_items) k = k + 1 new_data(k, 1) = first_col_items(j) new_data(k, 2) = items(1) new_data(k, 3) = items(2) new_data(k, 4) = items(3) Next j Next i ReDim Preserve new_data(1 To k, 1 To 4) ' 按照要求排序 Dim tmp As Variant For i = 1 To UBound(new_data) For j = i + 1 To UBound(new_data) If Len(new_data(i, 1)) > Len(new_data(j, 1)) Or _ (Len(new_data(i, 1)) = Len(new_data(j, 1)) And new_data(i, 1) > new_data(j, 1)) Then For k = 1 To 4 tmp = new_data(i, k) new_data(i, k) = new_data(j, k) new_data(j, k) = tmp Next k End If Next j Next i ' 输出结果 Dim rng As Range Set rng = Range("A1").Resize(UBound(new_data), 4) rng.Value = new_data End Sub ``` 以上代码中,我使用`Array`函数定义了一个原始数据数组,然后使用`Split`函数拆分每个元素,再将首列拆分为多行。最后,我使用冒泡排序对数组进行排序,并将结果输出到单元格中。请注意,这里使用了一维数组模拟二维数组,需要手动处理数组的维度。
评论 3
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值