Hogyan hozhat létre egyedi értékek listáját az Excel több munkalapjáról?

Van-e valami gyors módszer arra, hogy a munkafüzet összes munkalapjáról egyedi értékek listáját hozzuk létre? Például négy munkalapom van, amelyek felsorolják, hogy néhány név duplikátumokat tartalmaz az A oszlopban, és most az összes egyedi nevet szeretném kibontani ezekből a lapokból egy új listába, hogyan fejezhetném be ezt a munkát az Excelben?

Hozzon létre egy listát egyedi munkalapokról VBA kóddal

---

Hozzon létre egy listát egyedi munkalapokról VBA kóddal

Az összes munkalap egyedi értékeinek felsorolásához a következő VBA-kód szolgálhat Önnek, kérjük, tegye a következőket:

1. Tartsa lenyomva a ALT + F11 billentyűk megnyitásához Microsoft Visual Basic for Applications ablak.

2. Kattints betétlap > Modulok, és illessze be a következő makrót a Modulok Ablak.

VBA-kód: Hozzon létre egyedi munkalapok listáját több munkalapból:

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. A fenti kód beillesztése után nyomja meg a gombot F5 a kód futtatásához, és egy új munkalapot Egyedi érték létrejön, és az összes oszlopban az A oszlop egyedi nevei a következő képernyőképen szerepelnek: