vba行移动再合并

是 否 +2 论坛币

k人 参与回答

经管之家送您一份

应届毕业生专属福利!

求职就业群

赵安豆老师微信：zhaoandou666

经管之家联合CDA

送您一个全额奖学金名额~ !

立即领取

感谢您参与论坛问题回答

经管之家送您两个论坛币！

+2 论坛币

如何利用VBA将原表中的数据转换为结果表形式的数据?
说明:1.这样的数据有上万行
2.需要将一个分公司里的相同部门放在一起
3.在部门行位置变动的同时其他信息也应该跟着变动位置
4.变动后同一个分公司中的的相同部门进行合并
5.最终结果如结果表
详见附件
谢谢

扫码加我 拉你入群

请注明：姓名-公司-职位

以便审核进群资格，未注明则拒绝

分享0 收藏0 回帖

关键词：VBA 数据转换 分公司 行合并 在一起 移动

Sub 排序合并()
    Dim i As Long, j As Long
    Dim d As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    i = Range("a1").CurrentRegion.Rows.Count
    Range("a1:a" & i).UnMerge
    For j = 2 To i
        If Cells(j, 1) = "" Then
            Cells(j, 1) = Cells(j - 1, 1)
        Else
            d(Cells(j, 1).Value) = ""
        End If
    Next
    Application.AddCustomList listarray:=d.keys
    Range("a1").CurrentRegion.Sort key1:=Range("a1"), order1:=xlAscending, OrderCustom:=Application.CustomListCount + 1, key2:=Range("b1"), order2:=xlAscending, Header:=xlGuess
    Application.DeleteCustomList Application.CustomListCount
    For j = i To 2 Step -1
        If Cells(j, 1) = Cells(j - 1, 1) And Cells(j, 2) = Cells(j - 1, 2) Then
            Range(Cells(j - 1, 2), Cells(j, 2)).Merge
        End If
        If Cells(j, 1) = Cells(j - 1, 1) Then
            Range(Cells(j - 1, 1), Cells(j, 1)).Merge
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub 排序合并()
    Dim i As Long, j As Long
    Dim d As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    i = Range("a1").CurrentRegion.Rows.Count
    Range("a1:a" & i).UnMerge
    For j = 2 To i
        If Cells(j, 1) = "" Then
            Cells(j, 1) = Cells(j - 1, 1)
        Else
            d(Cells(j, 1).Value) = ""
        End If
    Next
    Application.AddCustomList listarray:=d.keys
    Range("a1").CurrentRegion.Sort key1:=Range("a1"), order1:=xlAscending, OrderCustom:=Application.CustomListCount + 1, key2:=Range("b1"), order2:=xlAscending, Header:=xlGuess
    Application.DeleteCustomList Application.CustomListCount
    For j = i To 2 Step -1
        If Cells(j, 1) = Cells(j - 1, 1) And Cells(j, 2) = Cells(j - 1, 2) Then
            Range(Cells(j - 1, 2), Cells(j, 2)).Merge
        End If
        If Cells(j, 1) = Cells(j - 1, 1) Then
            Range(Cells(j - 1, 1), Cells(j, 1)).Merge
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub