data unik

  1. 5 minggu lalu

    selamat malam para master, mohon bantuannya, saya sedang belajar menampilkan data siswa, tapi bukan dengan filter, hanya pada scrip ini hanya menampilkan data 1 kolom (nama), bagaimana menambah hasil data dengan nomer induknya, terima kasih sebelumnya.
    (file ini diambil dari hasil diskusi web ini)

  2. Caton

    Nov 5 Terverifikasi Indonesia + 15.164 Poin

    @bejo ...

    Ada beberapa cara yang bisa dilakukan. Untuk script yang sudah ada pada file yang mas @bejo upload di atas, contoh perbaikannya scriptnya seperti berikut:

    Private Sub CommandButton1_Click()
        Dim sFilter As String
        Dim xDict As Object
        Dim lIdx As Long
        Dim xArray, xKey
        
        On Error GoTo errHandler
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        sFilter = Me.[D2]
        Me.Range("F2:G" & Range("F100000").End(xlUp).Row).ClearContents
        Set xDict = CreateObject("Scripting.Dictionary")
        xArray = Me.Range("A2:C" & Range("A100000").End(xlUp).Row).Value2
        
        For lIdx = LBound(xArray) To UBound(xArray)
            If xArray(lIdx, 1) = sFilter Then
                xDict(xArray(lIdx, 3)) = xArray(lIdx, 2)
            End If
        Next
        
        If xDict.Count Then
            ReDim xArray(1 To xDict.Count, 1 To 2)
            
            lIdx = 1
            For Each xKey In xDict.Keys
                xArray(lIdx, 1) = xDict(xKey)
                xArray(lIdx, 2) = xKey
                lIdx = lIdx + 1
            Next
            
            Me.Range("F2").Resize(UBound(xArray, 1), UBound(xArray, 2)).Value = xArray
            Me.Range("F2:G" & Range("F100000").End(xlUp).Row).Sort Key1:=Range("F2"), Order1:=xlAscending
            
        End If
        
    errHandler:
        Err.Clear: On Error GoTo 0
        
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    
    End Sub

    Untuk baris script :

    ...
    Me.Range("F2:G" & Range("F100000").End(xlUp).Row).Sort Key1:=Range("F2"), Order1:=xlAscending
    ...

    bisa dihapus saja apabila data pada range asal (kolom A sampai dengan kolom C) sudah dalam keadaan tersortir.

    Demikian.

  3. Caton

    Nov 5 Terverifikasi Indonesia + 15.164 Poin

    Selain dengan script di atas, script berikut juga dapat digunakan, dengan syarat data pada range asal (kolom A sampai dengan kolom C) sudah dalam keadaan tersortir. Contoh scriptnya :

    Private Sub CommandButton1_Click()
        Dim lCount As Long, lX1 As Long, lX2 As Long
        Dim sFilter As String
        Dim xlRange As Range
        Dim xTemp, xArray
    
        On Error GoTo errHandler
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        sFilter = Me.Range("D2").Value2
        Me.Range("F2:G" & Me.Range("F100000").End(xlUp).Row + 5).ClearContents
        Set xlRange = Me.Range("A2:C" & Me.Range("A100000").End(xlUp).Row)
        lCount = Application.CountIf(xlRange.Resize(ColumnSize:=1), sFilter)
        If lCount Then
            xTemp = Application.Match(sFilter, xlRange.Resize(ColumnSize:=1), 0)
            If IsNumeric(xTemp) Then
                lX1 = xTemp + xlRange.Row - 1
                lX2 = lX1 + lCount - 1
                xTemp = Evaluate("=ROW(A" & lX1 - 1 & ":A" & lX2 - 1 & ")")
                xArray = Application.Index(xlRange.Value2, xTemp, Array(2, 3))
                Me.Range("F2").Resize(UBound(xArray, 1), UBound(xArray, 2)).Value = xArray
            End If
        End If
    
    errHandler:
        Err.Clear: On Error GoTo 0
        
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    
    End Sub

    Demikian alternatif scriptnya.

  4. Caton

    Nov 5 Terverifikasi Indonesia + 15.164 Poin
    Di sunting 5 minggu lalu oleh Caton

    Atau bisa juga menggunakan script berikut (tetap dengan syarat data pada range asal yakni kolom A sampai dengan kolom C, sudah dalam keadaan tersortir). Contoh scriptnya :

    Private Sub CommandButton1_Click()
        Dim lCount As Long, lPos As Long
        Dim sFilter As String
        Dim xlRange As Range
        
        On Error Resume Next
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        sFilter = Me.Range("D2").Value2
        Me.Range("F2:G" & Me.Range("F100000").End(xlUp).Row + 5).ClearContents
        Set xlRange = Me.Range("A2:A" & Me.Range("A100000").End(xlUp).Row)
        
        lCount = Application.CountIf(xlRange, sFilter)
        If lCount Then
            lPos = Application.Match(sFilter, xlRange, 0)
            If Err = 0 Then
                xlRange.Offset(lPos - 1, 1).Resize(lCount, 2).Copy
                With Me.Range("F2")
                    .PasteSpecial xlPasteValues
                    .Select
                End With
                Application.CutCopyMode = False
            End If
        End If
        
        Err.Clear: On Error GoTo 0
        
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    
    End Sub

    Demikian.

  5. YA ALLAH, COMPLETE BANGET MASTER, TERIMA KASIH BANYAK YA MASTER @CATON,, MASTER APAKAH VB NYA MACRO EXCEL BAHASANYA SAMA DENGAN VB??

  6. Caton

    Nov 5 Terverifikasi Indonesia + 15.164 Poin

    @bejo ...

    Sama-sama mas.

    Untuk VBA Macro, dialek bahasanya sama dengan Classic VisualBasic (VB6), karena memang bahasa pemrograman VBA itu merupakan turunan dari Classsic VB (VB6). Namun beda dengan VB .Net. Meskipun dialek bahasa pemrograman Classic VB hampir sama dengan VB .Net, namun banyak perbedaan konsep antara keduanya.

  7. terima kasih banyak master atas semua bantuannya, smoga saya bisa ketularan pinternya, aamiin

 

atau Mendaftar untuk ikut berdiskusi!