国产一级a片免费看高清,亚洲熟女中文字幕在线视频,黄三级高清在线播放,免费黄色视频在线看

Sub SplitDataByProject()    Dim dict As Object    Dim wsSource As Worksheet    Dim lastRow As Long, i As Long    Dim key As Variant    Dim newWb As Workbook    Dim newWs As Worksheet    Dim savePath As String
    '設(shè)置字典用于存儲唯一項目值    Set dict = CreateObject("Scripting.Dictionary")    Set wsSource = ThisWorkbook.Sheets("A表") '根據(jù)實際表名修改
    '獲取數(shù)據(jù)最后一行    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    '收集唯一項目值（排除標(biāo)題行）    For i = 2 To lastRow        If Not dict.exists(wsSource.Cells(i, 1).Value) Then            dict.Add wsSource.Cells(i, 1).Value, Nothing        End If    Next i
    '設(shè)置保存路徑（默認(rèn)為當(dāng)前工作簿路徑）    savePath = ThisWorkbook.Path & "\"
    Application.ScreenUpdating = False    Application.DisplayAlerts = False
    '循環(huán)處理每個項目    For Each key In dict.keys        '創(chuàng)建新工作簿        Set newWb = Workbooks.Add        Set newWs = newWb.Sheets(1)
        '復(fù)制標(biāo)題行        wsSource.Rows(1).Copy newWs.Rows(1)
        '篩選并復(fù)制數(shù)據(jù)        wsSource.Range("A1:F" & lastRow).AutoFilter Field:=1, Criteria1:=key        wsSource.UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy newWs.Range("A2")
        '清除篩選        wsSource.AutoFilterMode = False
        '保存文件        newWb.SaveAs savePath & key & ".xlsx"        newWb.Close    Next key
    '恢復(fù)設(shè)置    Application.ScreenUpdating = True    Application.DisplayAlerts = True
    MsgBox "已拆分生成 " & dict.Count & " 個文件！"End Sub