Kako ustvariti seznam edinstvenih vrednosti iz več delovnih listov v Excelu?
Ali lahko na hiter način ustvarimo seznam edinstvenih vrednosti iz vseh delovnih listov v delovnem zvezku? Na primer, imam štiri delovne liste, v katerih so nekatera imena podvojena v stolpcu A, zdaj pa želim iz teh listov izvleči vsa edinstvena imena na nov seznam, kako lahko to opravilo opravim v Excelu?
Ustvarite seznam edinstvenih vrednosti iz več delovnih listov s kodo VBA
Ustvarite seznam edinstvenih vrednosti iz več delovnih listov s kodo VBA
Če želite navesti vse edinstvene vrednosti z vseh delovnih listov, vam bo morda v korist naslednja koda VBA, storite tako:
1. Držite tipko ALT + F11 tipke za odpiranje Microsoft Visual Basic za aplikacije okno.
2. Kliknite Vstavi > Moduliin v mapo prilepite naslednji makro Moduli Okno.
Koda VBA: Ustvarite seznam edinstvenih vrednosti iz več delovnih listov:
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
3. Ko prilepite zgornjo kodo, pritisnite F5 za zagon te kode in nov delovni list z imenom Edinstvena vrednost je ustvarjen in so v stolpcu A na vseh listih navedena enolična imena, kot je prikazano na sliki spodaj:
Najboljša pisarniška orodja za produktivnost
Napolnite svoje Excelove spretnosti s Kutools za Excel in izkusite učinkovitost kot še nikoli prej. Kutools za Excel ponuja več kot 300 naprednih funkcij za povečanje produktivnosti in prihranek časa. Kliknite tukaj, če želite pridobiti funkcijo, ki jo najbolj potrebujete...
Kartica Office prinaša vmesnik z zavihki v Office in poenostavi vaše delo
- Omogočite urejanje in branje z zavihki v Wordu, Excelu, PowerPointu, Publisher, Access, Visio in Project.
- Odprite in ustvarite več dokumentov v novih zavihkih istega okna in ne v novih oknih.
- Poveča vašo produktivnost za 50%in vsak dan zmanjša na stotine klikov miške za vas!
