Milis punya blog yang berisi pembelajaran VBA. Ini alamat blognya :
http://b-excel.blogspot.com
Wassalam,
Kid.
On Sun, Feb 9, 2014 at 8:57 PM, <angan_l...@yahoo.co.id> wrote:
>
>
> Mohon bantuannya untuk penyempurnaan code berikut, code nya sudah
> mendekati PAS dengan kasus yg saya inginkan hanya saja ada sedikit
> kekurangan:
>
> 1. code hanya melakukan pencarian dan mewarnainya hanya pada 1 cell saja
> alias harus tekan CTRL+A baru secara
>
> secara keseluruhan mencari dan mewarnai. (yg saya inginkan sekali klik
> langsung mencari dan warnai semua)
>
> 2.saya ingin data yg ditemukan ditandai dengan warna merah tebal (bolt)
>
> 3. saya butuh semacam textbox (atau semacam itu hehehehe) untuk
> mengetikkan data yg diinginkan artinya agar tidak
>
> selalu memasukkan kata kunci di VBS module.
>
>
> Please Para master excel.. help me.. :(
>
>
> berikut code nya:
>
>
>
> Option Explicit
>
> Option Compare Text
>
> Sub testme()
>
>
> Application.ScreenUpdating = False
>
>
> Dim myWords As Variant
>
> Dim myRng As Range
>
> Dim foundCell As Range
>
> Dim iCtr As Long 'word counter
>
> Dim cCtr As Long 'character counter
>
> Dim FirstAddress As String
>
> Dim AllFoundCells As Range
>
> Dim myCell As Range
>
>
> 'add other words here
>
> myWords = Array("122")
>
>
> Set myRng = Selection
>
>
> On Error Resume Next
>
> Set myRng = Intersect(myRng, _
>
> myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
>
> On Error GoTo 0
>
>
> If myRng Is Nothing Then
>
> MsgBox "Please choose a range that contains text constants!"
>
> Exit Sub
>
> End If
>
>
> For iCtr = LBound(myWords) To UBound(myWords)
>
> FirstAddress = ""
>
> Set foundCell = Nothing
>
> With myRng
>
> Set foundCell = .Find(what:=myWords(iCtr), _
>
> LookIn:=xlValues, lookat:=xlPart, _
>
> after:=.Cells(.Cells.Count))
>
>
> If foundCell Is Nothing Then
>
> MsgBox myWords(iCtr) & "tidak ditemukan"
>
> Else
>
> Set AllFoundCells = foundCell
>
> FirstAddress = foundCell.Address
>
> Do
>
> If AllFoundCells Is Nothing Then
>
> Set AllFoundCells = foundCell
>
> Else
>
> Set AllFoundCells = Union(foundCell, AllFoundCells)
>
> End If
>
> Set foundCell = .FindNext(foundCell)
>
>
> Loop While Not foundCell Is Nothing _
>
> And foundCell.Address <> FirstAddress
>
> End If
>
>
> End With
>
>
> If AllFoundCells Is Nothing Then
>
> 'do nothing
>
> Else
>
> For Each myCell In AllFoundCells.Cells
>
> For cCtr = 1 To Len(myCell.Value)
>
> If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _
>
> = myWords(iCtr) Then
>
> myCell.Characters(Start:=cCtr, _
>
> Length:=Len(myWords(iCtr))) _
>
> .Font.ColorIndex = 3
>
> End If
>
> Next cCtr
>
> Next myCell
>
> End If
>
> Next iCtr
>
> Application.ScreenUpdating = True
>
>
> End Sub
>
>
>
> ---------------------------------------------------------FILE
> TERLAMPIR--------------------------------------------------------------------------------
>
>
>
