Pemanggilan Value Warna dan dijadikan sebagai data masukkan

  1. 8 bulan yang lalu
    Di sunting 8 bulan yang lalu oleh robyrnl
    Function angkut(seet As String, kotak As String)
    Dim rangesum As Variant
    Dim cr_range1 As Range
    Dim cr_range2 As Range
    Dim cr_range3 As Range
    Dim cr_range4 As Range
    Dim kriteria1 As Variant
    Dim kriteria2 As Variant
    Dim kriteria3 As Variant
    Dim kriteria4 As Variant
    Dim kriteria5 As Variant
    
    'menetukan nilai masing - masing variable
    Set rangesum = ThisWorkbook.Sheets(seet).Range("N:N")
    Set cr_range1 = ThisWorkbook.Sheets(seet).Range("M:M")
    Set cr_range2 = ThisWorkbook.Sheets(seet).Range("T:T")
    Set cr_range3 = ThisWorkbook.Sheets(seet).Range("R:R")
    Set cr_range4 = ThisWorkbook.Sheets(seet).Range("L:L")
    
    kriteria1 = ThisWorkbook.Sheets("REKAP").Range(kotak)
    kriteria2 = "1"
    kriteria3 = "T*"
    kriteria4 = "PN?"
    
    angkut = Application.WorksheetFunction.SumIfs(rangesum, cr_range1, kriteria1, cr_range2, _
    kriteria2, cr_range3, kriteria3, cr_range4, kriteria4)
    
    End Function

    mas @Caton saya masih ada sedikit masalah dengan kriteria2 = "1" yang sebenarnya angka 1 itu adalah kode warna dan saya harus memberikan nilai terlebih dahulu pada warna nya setelah itu baru saya gunakan fungsi angkut diatas. bagaimana supaya sa bisa menggabungkan nya menjadi 1 fungsi saja

    ini script untuk kode warna yang sudah saya buat
    Private Sub CommandButton1_Click() Dim str0 As String, str As String Dim cel As Range For Each cel In Selection str0 = Right("000000" & Hex(cel.Interior.Color), 6) str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2) If str = "FFFF00" Then 'kuning cel = "2" ElseIf str = "FF0000" Then 'merah cel = "3" ElseIf str = "007100" Then 'hijau cel = "1" End If: 'cel = "#" & str & "" Next cel done: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

    terimakasih atas bantuannya

  2. Caton

    25 Jan 2018 Terverifikasi Indonesia + 11.522 Poin

    Kalau digabungkan menjadi satu UDF, malah bisa-bisa memberatkan proses, karena pada setiap baris dimana UDF Angkut() digunakan, akan terjadi proses untuk memeriksa dan menandai warna sel. Sebaiknya kedua proses tetap dilakukan terpisah saja...

    Bila mau digabungkan juga, script untuk memeriksa dan menandai warna sel dibuat menjadi prosedur (Sub) tersendiri yang kemudian dipanggil melalui script pada fungsi Angkut(), misalkan:

    Private Sub PeriksaWarnaSel(Target As Range)
        Dim str0 As String, str As String
        Dim sColorHex As String
        Dim xlCell As Range
        Dim lIdx As Long
        
        On Error GoTo errHandler
        If Target.Columns.Count = 1 Then
            With Application
                .Calculation = xlCalculationManual
                .EnableEvents = False
                .ScreenUpdating = False
            End With
            
            lIdx = 0
            For Each xlCell In Target
                sColorHex = Right("000000" & Hex(xlCell.Interior.Color), 6)
                sColorHex = Right(sColorHex, 2) & Mid$(sColorHex, 3, 2) & Left$(sColorHex, 2)
                xlCell = vbNullString
                If sColorHex = "FFFFFF" Then
                    lIdx = lIdx + 1
                    If lIdx > 5 Then Exit For
                Else
                    xlCell = InStr(1, "007100|FFFF00|FF0000", sColorHex) Mod 6
                End If
            Next
            
    errHandler:
            
            Err.Clear
            With Application
                .Calculation = xlCalculationAutomatic
                .EnableEvents = True
                .ScreenUpdating = True
            End With
            On Error GoTo 0
        End If
    End Sub
    
    '+-- Assign Button ke prosedur ini.
    Public Sub PeriksaWarna()
        If Selection.Count Then
            Dim xlRange As Range
            
            If TypeName(Selection) = "Range" Then
                Set xlRange = Selection
                PeriksaWarnaSel xlRange.Rows
            End If
        End If
    End Sub
    
    Function Angkut(seet As String, kotak As String)
    Dim rangesum As Variant
    Dim cr_range1 As Range
    Dim cr_range2 As Range
    Dim cr_range3 As Range
    Dim cr_range4 As Range
    Dim kriteria1 As Variant
    Dim kriteria2 As Variant
    Dim kriteria3 As Variant
    Dim kriteria4 As Variant
    
    'menetukan nilai masing - masing variable
    Set rangesum = ThisWorkbook.Sheets(seet).Range("N:N")
    Set cr_range1 = ThisWorkbook.Sheets(seet).Range("M:M")
    Set cr_range2 = ThisWorkbook.Sheets(seet).Range("U:U")
    Set cr_range3 = ThisWorkbook.Sheets(seet).Range("R:R")
    Set cr_range4 = ThisWorkbook.Sheets(seet).Range("L:L")
    
    '+-- Panggil prosedur untuk memeriksa warna sel.
    PeriksaWarnaSel cr_range2.EntireColumn.Resize(cr_range2.Rows.Count - 16).Offset(16)
    
    kriteria1 = ThisWorkbook.Sheets("REKAP").Range(kotak)
    kriteria2 = "1"
    kriteria3 = "T*"
    kriteria4 = "PN?"
    
    angkut = Application.WorksheetFunction.SumIfs(rangesum, cr_range1, kriteria1, cr_range2, _
    kriteria2, cr_range3, kriteria3, cr_range4, kriteria4)
    End Function

    Dengan demikian, prosedur untuk memeriksa dan menandai warna sel masih dapat digunakan secara mandiri. Secara pribadi, saya tidak menyarankan hal tersebut. Saya hanya ingin memberikan gambaran bagaimana hal tersebut dapat dilakukan. Demikian... ;)

  3. maaf mas @Caton saya mencoba menggunakan script yang mas kasih, tapi saya belum berhasil menjalankan nya, saya coba memakai 1 button dan assign kan nya dengan prosedur yang ada diatas, namun hasilnya tidak ada dan saya juga coba langsung memanggil fungsi angkut() namun tidak bisa juga.

    mohon bantuan untuk pemanggilannya mas

  4. Caton

    26 Jan 2018 Terverifikasi Indonesia + 11.522 Poin

    Terlampir contoh script di atas, dengan beberapa perbaikan.

    Sori, saya lupa masalah ini. Jadi, pada VBA ada keterbatasan dari UDF, antara lain, saat sebuah UDF dipanggil, maka Excel akan mencegah beberapa proses, diantaranya proses mengubah nilai sebuah sel. Oleh karena prosedur PeriksaWarnaSel di atas akan mengubah nilai sel, Excel otomatis membatalkan proses pada prosedur tersebut. Namun bukan berarti tidak bisa diakali (lihat caranya pada script dalam file terlampir). Untuk eksekusi script VBA-nya dengan tombol, harus ada sel yang diseleksi dahulu (berupa range).

    Demikian... ;)

 

atau Mendaftar untuk ikut berdiskusi!