EXCEl按某一列拆分工作表到工作薄，并保持原来格式

WXY075675

lwwy1981 发表于 2020-6-23 21:43
什么样的表

根据日期突出字体颜色和设置倒计时

caixixin

之前学习的，你试试,可以选列
Option Explicit

Sub text()
Dim d As Object, sht As Worksheet
Dim adata, aresult, atemp, akeys, i&, j&, k&, x&
Dim rngdata As Range, rnggist As Range
Dim ingtitlecount&, inggistcol&, ingcolcount&
Dim rngformat As Range
Dim strkey As String



Set d = CreateObject("scripting.dictionary")
Set rnggist = Application.InputBox("拆分列", Title:="", Type:=8)
inggistcol = rnggist.Column
ingtitlecount = Val(Application.InputBox("标题行数"))
If ingtitlecount < 0 Then MsgBox "": Exit Sub



Set rngdata = ActiveSheet.UsedRange
Set rngformat = ActiveSheet.Cells
adata = rngdata.Value
inggistcol = inggistcol - rngdata.Column + 1
ingcolcount = UBound(adata, 2)

For i = Sheets.Count To 1 Step -1
Application.DisplayAlerts = False
        

    Next i

For i = ingtitlecount + 1 To UBound(adata)
    If adata(i, inggistcol) = "" Then adata(i, inggistcol) = ""
    strkey = adata(i, inggistcol)
    If Not d.exists(strkey) Then
    d(strkey) = i
    Else
    d(strkey) = d(strkey) & "," & i
    End If
Next

Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
If d.exists(sht.Name) Then sht.Delete
Next
Application.DisplayAlerts = True
akeys = d.keys
Application.ScreenUpdating = False

Dim rd As Range
Dim ad
Dim z
Set rd = Sheets("sheet2").UsedRange
ad = rd.Value

For i = 0 To UBound(akeys)


If akeys(i) <> ""  Then



atemp = Split(d(akeys(i)), ",")
ReDim aresult(1 To UBound(atemp) + 1, 1 To ingcolcount)
k = 0
For x = 0 To UBound(atemp)
k = k + 1
For j = 1 To ingcolcount
aresult(k, j) = adata(atemp(x), j)
Next
Next

With Worksheets.Add(, Sheets(Sheets.Count))
.Name = akeys(i)

    [a1].Resize(UBound(adata), ingcolcount).NumberFormat = "@"
        If ingtitlecount > 0 Then .[a1].Resize(ingtitlecount, ingcolcount) = adata
    [a1].Offset(ingtitlecount, 0).Resize(k, ingcolcount) = aresult
        rngformat.Copy
     .[a1].PasteSpecial Paste:=xlPasteFormats, operation:=xlNone, skipblanks:=False, Transpose:=False
[a1].Offset(ingtitlecount + k, 0).Resize(UBound(adata) - k - ingtitlecount, 1).EntireRow.Delete
     .[a1].Select
     End With

End If
Next

rngdata.Parent.Activate
Application.ScreenUpdating = True
Set d = Nothing
Set rngdata = Nothing
Set rnggist = Nothing
Set rngformat = Nothing
Erase adata: Erase aresult
MsgBox "拆分完成"

End Sub

hezijie1986

Sub cf()
    Dim d As Object
    Dim arr, brr
    Dim i As Long, jn As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
        Worksheets("那丽镇").Select
        arr = Range("a5:q" & Cells(Rows.Count, "a").End(xlUp).Row).Value
        For i = 1 To UBound(arr)
            d(arr(i, 4)) = ""
        Next
        
        For Each sht In Worksheets
            If sht.Name <> "那丽镇" Then
                sht.Delete
            End If
        Next
        
        For Each jn In d.keys()
            Worksheets.Add after:=Worksheets(Sheets.Count)
            Worksheets(Sheets.Count).Name = jn
            Worksheets("那丽镇").Select
            Range("a1:q4").Copy Destination:=Worksheets(jn).Range("a1:q4")
            Worksheets(jn).Select
            k = 4 '从第五行开始存
            m = 0 '序号
                For i = 1 To UBound(arr)
                    If ActiveSheet.Name = arr(i, 4) Then '判断当前sheet名称和第四列是否相等
                        k = k + 1 '累加相等的行数
                        m = m + 1
                        For j = 1 To UBound(arr, 2)
                            Cells(k, j) = arr(i, j) '将符合条件的循环填入单元格
                            Cells(k, 1) = m
                        Next
                        
                    End If
                Next
        Next
   
   
    Set d = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub