Skripty VBA pro Excel

Najde unikatní výskyt a vrátí jeho počet v rozsahu

Sub xy()
Dim i, x, zapis, aktual, y
Dim ws_name As String
Dim sht As Worksheet

'rozsah hledani
rada = Application.InputBox("Select range to search for Unique values", "Search area", Type:=8)
'zadani jmena noveho worksheetu
wsname = Application.InputBox("Name of new worksheet where results will be writen. If name match with exists, then will truncate data from existing worksheet", "Results worksheet name", "Unique_Count", Type:=2)
ws_name = wsname
'vytvoreni noveho worksheetu, pripadne vycisteni stavajiciho
        Application.DisplayAlerts = False
            If SheetExists(ws_name) Then
                Sheets(ws_name).Delete
            End If
            Worksheets.Add().Name = ws_name
        Application.DisplayAlerts = True

Set sht = Sheets(ws_name)          'jmeno worksheetu kam zapisovat vysledky, vyuzije sloupce A,B

sht.Range("A1") = "Name"
sht.Range("B1") = "Count"

i = 0       'id jednotliveho prvku vy vybranem prostredi (range)
krok = 0    'id prvku v seznamu unikatnich vysledku
zapis = 1   'cislo radku posledniho unikatniho vysledku


    For Each i In rada
        y = 0 'kontroluje, estli neni v seznamu unikatnich
        If i <> "" Then
            For krok = 1 To zapis
                If sht.Range("A" & krok).Value <> i Then
                 
                 y = 0
                Else:
                    y = 1
                    sht.Range("B" & krok).Value = sht.Range("B" & krok).Value + 1
                    Exit For
                End If
             
            Next krok
            If y = 0 Then
                zapis = zapis + 1
                sht.Range("A" & zapis).Value = i
                sht.Range("B" & zapis).Value = 1
            End If
        End If
    
    Next i
End Sub

Function SheetExists(SheetName As String) As Boolean
' returns TRUE if the sheet exists in the active workbook
    SheetExists = False
    On Error GoTo NoSuchSheet
    If Len(Sheets(SheetName).Name) > 0 Then
        SheetExists = True
        Exit Function
    End If
NoSuchSheet:
End Function

Export listu do csv file

Sub zapis_do_txt()
    Dim FilePath As String
    Dim CellData As String
    Dim LastCol As Long
    Dim LastRow As Long
    
    
    LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
    LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    
    Rem FilePath = "C:\Users\Standa\Desktop\pokus.csv"
    FilePath = Environ("TEMP") + "\test.csv"
    
    Open FilePath For Output As #2
    
    For i = 1 To LastRow
        CellData = "[" + Chr(34)
        For j = 1 To LastCol
    
            If j = LastCol Then
                CellData = CellData + Trim(ActiveCell(i, j).Value) + Chr(34) + "],"
            Else
                CellData = CellData + Trim(ActiveCell(i, j).Value) + Chr(34) + "," + Chr(34)
            End If
    
        Next j
    
        Print #2, CellData
        
        
    
    Next i
    
    Close #2
    MsgBox ("Done saved in: " + FilePath)
End Sub