如何将表格拆分

rayofu

有一张数据的汇总表，想根据表体中的供应商拆分，表头表尾不变，表头表尾中的供应商变为拆分的供应商，是否能够实现？
这是原表，想拆分成下面的

高个子

你这个最后一行供应商比较麻烦，基本操作只能做到没有后面供应商的，所以建议VBA一步到位。

minijc

wps→开始→工作表→拆分表格→工作表→拆分依据（选择供应商列）→拆分

680926

Sub test1()
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
Dim arr, i, j, m
Dim sht As Worksheet
Application.DisplayAlerts = False
arr = Sheet1.Range("g4", Sheet1.Range("g65536").End(xlUp))

For i = 1 To UBound(arr)
    dic(arr(i, 1)) = arr(i, 1)
Next
x = dic.keys

For Each sht In Sheets
    If sht.Name <> "Sheet1" Then
        sht.Delete
    End If
Next

For j = 1 To dic.Count
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = x(j - 1)
    Sheet1.Range("a3:g3").AutoFilter field:=7, Criteria1:=x(j - 1)
    Sheet1.UsedRange.Copy Sheets(Sheets.Count).Range("a1")
    Sheets(Sheets.Count).Range("a65536").End(xlUp).Offset(1, 0) = "o&#207;&#188;&#198;"
    Sheets(Sheets.Count).Range("d65536").End(xlUp).Offset(1, 0) = Application.WorksheetFunction.Sum(Range("d3", Range("d65536").End(xlUp)))
    Sheets(Sheets.Count).Range("a65536").End(xlUp).Offset(1, 0) = "1&#169;ó|éì"
    Sheets(Sheets.Count).Range("a65536").End(xlUp).Offset(0, 1) = x(j - 1)
    m = Sheets(Sheets.Count).Range("a65536").End(xlUp).Row
    Sheets(Sheets.Count).Range("a2", Sheets(Sheets.Count).Range("g" & m)).Borders.LineStyle = xlContinuous
Next

Sheet1.Range("a3:g3").AutoFilter
Application.DisplayAlerts = False
End Sub
Sub test2()
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
Dim arr, i, j, m
Dim sht As Worksheet
Application.DisplayAlerts = False
arr = Sheet1.Range("g4", Sheet1.Range("g65536").End(xlUp))

For i = 1 To UBound(arr)
    dic(arr(i, 1)) = arr(i, 1)
Next
x = dic.keys

For Each sht In Sheets
    If sht.Name <> "Sheet1" Then
        sht.Delete
    End If
Next

For j = 1 To dic.Count
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(j - 1)
    Sheet1.UsedRange.Copy Sheets(Sheets.Count).Range("a1")
    For m = Sheets(Sheets.Count).Range("g65536").End(xlUp).Row To 4 Step -1
        If Range("g" & m).Value <> x(j - 1) Then
            Range("g" & m).EntireRow.Delete
        End If
    Next
    Sheets(Sheets.Count).Range("a65536").End(xlUp).Offset(0, 1) = x(j - 1)
Next

Sheet1.Range("a3:g3").AutoFilter
Application.DisplayAlerts = False
End Sub