[已解决]VBA有一个总表的工作表2

laoau138

VBA有一个总表的工作表2

最佳答案

月排行榜 / 总排行榜

xiangbaoan

2017-4-23 21:35

>>>晚上好！>>>

跳转到最佳答案楼层

xiangbaoan

>>>晚上好！>>>

laoau138

xiangbaoan 发表于 2017-4-23 21:35
>>>晚上好！>>>

果然是高手，

Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d, Arr, sht As Worksheet, r, k, i, lr
Set d = CreateObject("scripting.dictionary")
Arr = Worksheets("总表").[a1].CurrentRegion
For Each sht In Sheets
    If sht.Name <> "总表" Then sht.Delete   '删除旧表
Next
For r = 2 To UBound(Arr)
    d(Arr(r, 2)) = ""   '得到表名
Next
k = d.keys
For i = 0 To UBound(k)
    With ActiveWorkbook.Worksheets.Add(, after:=ActiveSheet)   '建表
        .Name = k(i)   '表名
        .[a1].Resize(1, UBound(Arr, 2)) = Application.Index(Arr, 1, 0)   '表标题行
    End With
Next
For r = 2 To UBound(Arr)
    With Worksheets(Arr(r, 2)) '相应表
        lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 '相应表A列非空单元格行号+1
        .Range("a" & lr).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, r, 0)   '相应位置写入
    End With
Next
Sheet1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

327718098

laoau138 发表于 2017-4-23 21:50
果然是高手，

Sub test()

边打游戏边写的，发出来看看
Sub text()
Dim rng As Range, hh As Long, wb As String, gzb As Worksheet
hh = 2
Do While Sheet1.Cells(hh, 1) <> ""
If Application.WorksheetFunction.CountIf(Sheet1.Range("b2:b" & hh), Sheet1.Cells(hh, 2)) = 1 Then
wb = Sheet1.Cells(hh, 2).Value
Set gzb = Worksheets.Add
gzb.Name = wb
Sheet1.Range("a1").Resize(1, 6).Copy Sheets(wb).Range("a1")
Else
End If
wb = Sheet1.Cells(hh, 2)
Set rng = Sheets(wb).Cells(Rows.Count, 1).End(3).Offset(1, 0)
Sheet1.Cells(hh, 1).Resize(1, 6).Copy rng
hh = hh + 1
Loop
End Sub