如何在Excel中的多個工作表中創建唯一值列表？

Sub SheelsUniqueValues() Dim xObjNewWS As Worksheet Dim xObjWS As Worksheet Dim xStrAddress As String Dim xIntRox As Long Dim xIntN As Long Dim xFNum As Integer Dim xMaxC, xColumn As Integer Dim xR As Range xStrName = "Unique value" Application.ScreenUpdating = False xMaxC = 0 Application.DisplayAlerts = False For Each xObjWS In Sheets If xObjWS.Name = xStrName Then xObjWS.Delete Exit For End If Next Application.DisplayAlerts = True For xFNum = 1 To Sheets.Count xColumn = Sheets(xFNum).Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column If xMaxC < xColumn Then xMaxC = xColumn End If Next xFNum Application.DisplayAlerts = True Set xObjNewWS = Sheets.Add(after:=Sheets(Sheets.Count)) xObjNewWS.Name = xStrName For xColumn = 1 To xMaxC xIntN = 1 For xFNum = 1 To Sheets.Count - 1 Set xR = Sheets(xFNum).Columns(xColumn) If TypeName(Sheets(xFNum).Columns(xColumn).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)) <> "Nothing" Then xIntRox = xR.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Sheets(xFNum).Range(Cells(1, xColumn).Address & ":" & Cells(xIntRox, xColumn).Address).Copy Cells(xIntN, xColumn).PasteSpecial xlValues xIntN = xIntRox + xIntN + 1 End If Next xFNum If xIntRox - 1 > 0 Then xIntRox = xIntN - 1 xStrAddress = Cells(1, xColumn).Address & ":" & Cells(xIntRox, xColumn).Address Range(xStrAddress).AdvancedFilter Action:=xlFilterInPlace, Unique:=True Range(xStrAddress).Copy Cells(1, xColumn + 1).PasteSpecial xlValues Range(xStrAddress).AdvancedFilter Action:=xlFilterInPlace, Unique:=False Columns(xColumn).Delete Range(xStrAddress).Sort key1:=Cells(1, xColumn), Header:=xlNo End If Next xColumn Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

最佳辦公生產力工具

在Word，Excel，PowerPoint中啟用選項卡式編輯和閱讀，發布者，Access，Visio和Project。 在同一窗口的新選項卡中而不是在新窗口中打開并創建多個文檔。 每天將您的工作效率提高50％，并減少數百次鼠標單擊！