Excel Flashing Cell

The Flashing Cell When Certain Condition Is Met

         In our example, if the value of cell A1 is greater than 5, this cell starts to flash. The flashing event is realized by changing the background color and font color of the cell at a particular time (firstly red ,then white color) .



         We added a module to ensure the cell flash and paste the following codes into the module:
Sub auto_open()
If Range("A1").Value > 5 Then
Call basla
End If
End Sub

Sub auto_close()
dur = True
End Sub

Sub basla()
If dur = True Then Exit Sub
If Range("A1").Value <= 5 Then
Exit Sub
End If
If Format(Now, "ss") Mod 2 = 0 Then
Range("A1").Interior.Color = vbRed
Range("A1").Font.Color = vbWhite
Range("A1").Font.Size = 11
Range("A1").Font.Bold = True
Else
Range("A1").Interior.ColorIndex = xlNone
Range("A1").Font.Color = vbBlack
Range("A1").Font.Bold = False
End If
Call saat
End Sub

Sub saat()
Application.OnTime Now + TimeValue("00:00:01"), "basla"
End Sub

We enabled the macro to start automatically with VBA auto_open method.
Sub auto_open()
If Range("A1").Value > 5 Then
Call basla
End If
End Sub


Read more ...

Excel Change Background Color of Selected Cells With Scrollbar Control On Userform

Excel VBA: Change Cell's Background Color With Userform


          The userform starts as automatically when the worksheet is opened .Background color of selected cells can be changed with VBA scrollbar control on this userform.
The scrollbar's min value is 0, the maximum value is 56.

The related VBA codes:
Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub ScrollBar1_Change()
TextBox1.Value = ScrollBar1.Value
Selection.Interior.ColorIndex = ScrollBar1.Value
End Sub

Private Sub UserForm_Initialize()
ScrollBar1.Min = 0
ScrollBar1.Max = 56
End Sub


excel change background color


Read more ...

Hide & Unhide Columns With Combobox

Excel VBA Display The Selected A Column From Combobox


excel hide column

                 In this template, only the selected column from the combobox is displayed ,other columns are hidden.The used codes in this template :
Private Sub CheckBox1_Click()
ActiveSheet.Cells.EntireColumn.Hidden = False
End Sub

Private Sub ComboBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Me.ComboBox1.DropDown
End Sub

Private Sub UserForm_Initialize()
  Dim lst_column As Integer
    lst_column = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
For j = 2 To lst_column
   ComboBox1.AddItem Split(ActiveSheet.Cells(1, j).Address, "$")(1) & " " & "-" & Cells(1, j).Value
Next j
End Sub

Private Sub ComboBox1_Change()
   Dim lst_column As Integer
lst_column = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    For j = 2 To lst_column
 
     Columns(Split(ActiveSheet.Cells(1, j).Address, "$")(1)).EntireColumn.Hidden = True
Next j
Columns(ComboBox1.ListIndex + 2).EntireColumn.Hidden = False
End Sub


excel hide unhide columns vba

Read more ...

Fast Date Entry To Active Cell With Right-Click Menu

Userform To Insert Date (Alternative To Date Picker and Calendar Control)


       
        In our template ,firstly we first added a new item - DATE FORM - to the right click menu using VBA codes :
Sub Addmenu()
Application.CommandBars("Cell").Reset   'Right click menu will be reset.
With Application.CommandBars("Cell").Controls
With .Add(Before:=1)
   .Caption = "DATE FORM"  'Menu caption you want to add
   .FaceId = 39
   .OnAction = ThisWorkbook.Name & "!MacroName"  'Macro you want to run
   .Tag = "MacroName"
   .BeginGroup = True  'New Group
End With
End With
End Sub

When the workbook is opened , the new item is automatically added  with the Auto_Open method to the right click menu :
Sub Auto_Open()
Call Addmenu
End Sub

This new item that we added is removed through Auto_Close method when the workbook is closed  :
Sub Auto_Close()
Call menureset
End Sub

Sub menureset()
Application.CommandBars("Cell").Reset 'Right click menu will be reset.
End Sub

        We added all the methods related to the right click menu to the VBE window by adding a new module (Module1) and pasted it there. Thus ,the right click menu can be used on all pages of the workbook with the addition of new item.



        When right-clicked on the active cell, context menu is opened.
We click on the "DATE FORM"  that we created via the module in the context menu.
When the date userform is opened, it will automatically appear today's date. If you wish, you can select another date with the help of the drop-down boxes to enter the cell.

        At the bottom of the userform, you can see which day the selected date corresponds to.
You can use the date form on all sheets of the workbook.

 The userform contains three combo boxes (for month,day,year).

         The date selected from the combo boxes is displayed as short date (dd.mm.yyyy) in the textbox. The day name for the date is reported in the label control on textbox's right ; sunday,monday etc. Related codes :
TextBox1 = VBA.Format(DateSerial(VBA.CLng(Me.cboYear.Value), Me.cboMonth.ListIndex + 1, Me.cboDay.Value))
Label1.Caption = WeekdayName(Weekday(TextBox1, 0), False, 0)
..
       
          When the button is pressed, the selected date is entered into the cell and userform closes.
To use the date form in your own workbooks, copy and paste the module and date form.

Userform To Insert Date -Alternative To Date Picker and Calendar Control

Read more ...

Excel VBA Remove Duplicates

Excel VBA Remove Duplicate Values In Row With Loop
         The duplicate values in the column can be deleted with a simple For-Next loop. For example, column A was taken as the basis in this template. The used loop's codes :
Sub remove()
Dim a As Long
For a = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & a), Cells(a, 1)) > 1 Then Rows(a).Delete
Next
End Sub

excel remove duplicates


Excel Vba Remove Duplicate Values In A Row


Read more ...

Excel VBA Merge Multiple Sheets Into One Worksheet

Merge Multiple Sheets Into One Worksheet & Receive Subtotal


excel vba merge multiple sheets


          Excel users usually need to merge multiple worksheets into a single main worksheet, so that the data can be analyzed quickly and easily.
In this template ago, we combined all sheets into one sheet :
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Grand_Table"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Last = FindLastRow(Sheets(1))
Selection.Copy
With Sheets(1).Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Next
...


        Later, we sorted in ascending order the data in created main sheet and received subtotal of column that we selected :
Sheets("Grand_Table").UsedRange.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6), _
Replace:=True, PageBreaks:=True, SummaryBelowData:=True

 "TotalList: = Array (6)" expression in subtotal codes indicates Column 6.

       We highlighted the subtotal cells by coloring them :
For Each Rng In Selection
If Rng.HasFormula Then
With Rng
.Interior.ColorIndex = 37
.Font.Bold = True
End With
End If
Next


Especially with this template, the months of year are merged into a single sheet, and subtotals can be received and analyzed yearly data easily.

Merge Multiple Sheets Into One Worksheet

Read more ...

Excel Highlight Row And Column Of Active Cell

Excel VBA Highlight The Selected Cell


          When a cell is selected in sheet , Excel highlights the row and column with shapes by creating the background color and border of the associated row and column .


VBA codes to create shape on the selected cell:
Private Sub SekilYap()
Dim SatirCizgisi1 As Shape
Dim SutunCizgisi1 As Shape
Dim SatirCizgisi2 As Shape
Dim SutunCizgisi2 As Shape
Dim wR As Range

SutunDolguRengi = 44
SatirDolguRengi = 44
SatirDolgusuOlsunmu = msoTrue
SutunDolgusuOlsunmu = msoTrue
SatirSaydamligi = 0.8
SutunSaydamligi = 0.8
SatirCizgiRengi = 4
SutunCizgiRengi = 4
SatirCizgiKalinligi = 1
SutunCizgiKalinligi = 1

'Application.ScreenUpdating = False On Error Resume Next
Set SatirCizgisi1 = ActiveSheet.Shapes("SatirCizgisi1")
Set SutunCizgisi1 = ActiveSheet.Shapes("SutunCizgisi1")
Set SatirCizgisi2 = ActiveSheet.Shapes("SatirCizgisi2")
Set SutunCizgisi2 = ActiveSheet.Shapes("SutunCizgisi2")
Set wR = ActiveWindow.VisibleRange

If SatirCizgisi1 Is Nothing Then
Set SatirCizgisi1 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, ActiveCell.Top, ActiveCell.Left, ActiveCell.Height)
With SatirCizgisi1
.Name = "SatirCizgisi1"
.Line.Weight = SatirCizgiKalinligi
.Line.ForeColor.SchemeColor = SatirCizgiRengi
.Fill.Solid
.Fill.Visible = SatirDolgusuOlsunmu
.Fill.Transparency = SatirSaydamligi
.Fill.ForeColor.SchemeColor = SatirDolguRengi 'fill.visible=msoTrue iken işe yarar, arka plan rengi
End With
End If
If SatirCizgisi2 Is Nothing Then
Set SatirCizgisi2 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Offset(0, 1).Left, ActiveCell.Top, ActiveSheet.Columns.Width - ActiveCell.Left, ActiveCell.Height)
With SatirCizgisi2
.Name = "SatirCizgisi2"
.Line.Weight = SatirCizgiKalinligi
.Line.ForeColor.SchemeColor = SatirCizgiRengi
.Fill.Solid
.Fill.Visible = SatirDolgusuOlsunmu
.Fill.Transparency = SatirSaydamligi
.Fill.ForeColor.SchemeColor = SatirDolguRengi
End With
End If
If SutunCizgisi1 Is Nothing Then
Set SutunCizgisi1 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, 0, ActiveCell.Width, ActiveCell.Top)
With SutunCizgisi1
.Name = "SutunCizgisi1"
.Line.Weight = SutunCizgiKalinligi
.Line.ForeColor.SchemeColor = SutunCizgiRengi
.Fill.Solid
.Fill.Visible = SutunDolgusuOlsunmu
.Fill.Transparency = SutunSaydamligi
.Fill.ForeColor.SchemeColor = SutunDolguRengi
End With
End If
If SutunCizgisi2 Is Nothing Then
Set SutunCizgisi2 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Offset(1, 0).Top, ActiveCell.Width, ActiveSheet.Cells.Height - ActiveCell.Left)
With SutunCizgisi2
.Name = "SutunCizgisi2"
.Line.Weight = SutunCizgiKalinligi
.Line.ForeColor.SchemeColor = SutunCizgiRengi
.Fill.Solid
.Fill.Visible = SutunDolgusuOlsunmu
.Fill.Transparency = SutunSaydamligi
.Fill.ForeColor.SchemeColor = SutunDolguRengi
End With
End If

With SatirCizgisi1
.Left = 0
.Top = ActiveCell.Top
.Width = ActiveCell.Left
.Height = ActiveCell.Height
End With
With SatirCizgisi2
.Left = ActiveCell.Offset(0, 1).Left
.Top = ActiveCell.Top
.Width = ActiveSheet.Columns.Width - ActiveCell.Left
.Height = ActiveCell.Height
End With
With SutunCizgisi1
.Left = ActiveCell.Left
.Top = 0
.Width = ActiveCell.Width
.Height = ActiveCell.Top
If ActiveCell.Top > 169056 Then
.Top = ActiveCell.Top - 169056
End If
End With

With SutunCizgisi2
.Left = ActiveCell.Left
.Top = ActiveCell.Offset(1, 0).Top
.Width = ActiveCell.Width
.Height = ActiveSheet.Cells.Height - ActiveCell.Left
End With
Application.ScreenUpdating = True
End Sub

excel highlight row column


Read more ...

Excel VBA Animation Example

Animation In Sheet



            A good animation example made with the following Excel VBA codes :

Sub Animasyon13()
    ActiveSheet.Shapes("Ferman").Select
    Selection.Characters.Delete
        m = 0
    For i = 1 To 140
      Selection.ShapeRange.Width = m
      Selection.ShapeRange.Adjustments.Item(1) = k
      m = m + 1
      k = k + 1
      DoEvents
    Next i
        Selection.Characters.Text = Range("a1").Value
        With Selection.Characters(Start:=1, Length:=22).Font
        .Name = "Arial"
        .FontStyle = "Normal"
        .Size = 11
        .Bold = True
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = True
        .Shadow = True
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 12
    End With
    Range("A1").Select
End Sub


excel animation


Read more ...

Excel VBA Insert Sequence Numbers Quickly With Input Boxes

Create Multiple Inputbox With Excel VBA


          The sequence numbers can be added into the wished column with macro. When the button on the page is clicked, our macro starts running .Input boxes  are opened in sequence.
Input boxes ask the questions to the user.
          The sequence numbers are added to the selected column according to the answers given by the user.




VBA Codes of input boxes :
cevap1 = InputBox("Please ,Select The Column You Want To Enter The Sequence Numbers." & vbNewLine & vbNewLine & _
"Column Numbers and Their's Letters" & vbNewLine _
& vbNewLine & "1 -> A 10 -> J 19 -> S" _
& vbNewLine & "2 -> B 11 -> K 20 -> T" _
& vbNewLine & "3 -> C 12 -> L 21 -> U" _
& vbNewLine & "4 -> D 13 -> M 22 -> V" _
& vbNewLine & "5 -> E 14 -> N 23 -> W" _
& vbNewLine & "6 -> F 15 -> O 24 -> X" _
& vbNewLine & "7 -> G 16 -> P 25 -> Y" _
& vbNewLine & "8 -> H 17 -> Q 26 -> Z" _
& vbNewLine & "9 -> I 18 -> R ........" _
& vbNewLine & vbNewLine & "Press OK Button After Writing Your Answer .", "COLUMN", "1")

cevap2 = InputBox("Which Rows to Begin?" & vbNewLine & vbNewLine & _
"Press OK Button After Writing Your Answer .", "Row", "2")

cevap3 = InputBox("Enter The Sequence Number to Begin From Which Number." & vbNewLine & vbNewLine & _
"Press OK Button After Writing Your Answer .", "The Number Of Start", 1)


excel vba multiple inputbox



Read more ...

Excel Convert A Numeric Value Into English Words

Excel VBA Convert Numeric Value To Text



           The NumbertoText Function is used for this process. Also,  Dollars and Cents are added to last of words according to the situation.
For to add in a workbook and to use this function :
1. Open any workbook.
2. Press ALT+F11  to open the Visual Basic Application Window.
3. On the Insert menu, click Module.
4. Type the following code into the module.
Function NumbertoText(ByVal MyNumber)
Dim Dollars, Cents, Temp As String
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "

' String representation of amount
MyNumber = Trim(Str(MyNumber))
' Position of decimal place 0 if none
DecimalPlace = InStr(MyNumber, ".")
'Convert cents and set MyNumber to dollar amount
If DecimalPlace > 0 Then
Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If

Count = 1
Do While MyNumber <> ""
Temp = GetHundreds(Right(MyNumber, 3))
If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop

Select Case Dollars
Case ""
Dollars = "No Dollars"
Case "One"
Dollars = "One Dollar"
Case Else
Dollars = Dollars & " Dollars"
End Select

Select Case Cents
Case ""
Cents = " and No Cents"
Case "One"
Cents = " and One Cent"
Case Else
Cents = " and " & Cents & " Cents"
End Select
NumbertoText = Dollars & Cents
End Function

' Converts a number from 100-999 into text
Private Function GetHundreds(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
'Convert the hundreds place
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
End If

'Convert the tens and ones place
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(MyNumber, 2))
Else
Result = Result & GetDigit(Mid(MyNumber, 3))
End If
GetHundreds = Result
End Function

' Converts a number from 10 to 99 into text. *
Private Function GetTens(TensText)
Dim Result As String
Result = "" 'null out the temporary function value
If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19
Select Case Val(TensText)
Case 10: Result = "Ten"
Case 11: Result = "Eleven"
Case 12: Result = "Twelve"
Case 13: Result = "Thirteen"
Case 14: Result = "Fourteen"
Case 15: Result = "Fifteen"
Case 16: Result = "Sixteen"
Case 17: Result = "Seventeen"
Case 18: Result = "Eighteen"
Case 19: Result = "Nineteen"
Case Else
End Select
Else ' If value between 20-99
Select Case Val(Left(TensText, 1))
Case 2: Result = "Twenty "
Case 3: Result = "Thirty "
Case 4: Result = "Forty "
Case 5: Result = "Fifty "
Case 6: Result = "Sixty "
Case 7: Result = "Seventy "
Case 8: Result = "Eighty "
Case 9: Result = "Ninety "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1)) 'Retrieve ones place
End If
GetTens = Result
End Function

' Converts a number from 1 to 9 into text.
Private Function GetDigit(Digit)
Select Case Val(Digit)
Case 1: GetDigit = "One"
Case 2: GetDigit = "Two"
Case 3: GetDigit = "Three"
Case 4: GetDigit = "Four"
Case 5: GetDigit = "Five"
Case 6: GetDigit = "Six"
Case 7: GetDigit = "Seven"
Case 8: GetDigit = "Eight"
Case 9: GetDigit = "Nine"
Case Else: GetDigit = ""
End Select
End Function


       The function can be used on all sheets of the workbook. .For example, enter "the number 50" into cell G1, and enter the following formula into another cell:
=NumbertoText(G1)
The result will be as this : Fifty Dollars and No Cents

- If desired, the function can be adapted to the Euro by changing the Dollar words with Euro words.

Excel Convert Numeric Value To Words

          This function is particularly useful for templates such as invoice. Previously we used the function in the invoice templates:

excel from number to text






Read more ...

Excel Add Blank Rows With Checkbox Or Button

Excel VBA Add Blank Rows


            New blank rows can be added under each row with checkbox and button controls . Blank rows can be deleted with the deleting button.
The new rows are added as blank rows under each rows.


 The used codes to add - remove rows with checkbox :
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
Call Addrow
Else
Call Clr
End If
End Sub

Sub Addrow()     ' The main procedure that allows us to add blank rows under filled rows
Dim a As Byte
Dim c As Integer
[A1].Select
a = 2
c = 0
While ActiveCell.Value <> ""
c = c + 2
ActiveSheet.Rows(c).Insert Shift:=xlDown
ActiveCell.Offset(a, 0).Select
Wend
End Sub

Sub Clr()
On Error Resume Next
Range("A2").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Excel VBA Add Row

 The used codes to add - remove rows with buttons :
Private Sub CommandButton1_Click()
Call Addrow
End Sub

Private Sub CommandButton2_Click()
Call Clr
End Sub
excel vba add blank row
excel vba add blank rows

Read more ...

Excel Sheet Adding - Deleting With Userform

Excel VBA Add Sheet - Assigning Macro To Short-Cut Key



       We created a userform and added a listbox, combobox, buttons, textbox control into the userform.
With this userform, a new sheet can be added to the workbook, the sheet can be deleted and can be navigated between sheets of the workbook .     
        If   key in keyboard is pressed on the any sheet, the userform opens. Because ,we assigned a macro that it provides userform is opened for excel assing macro to key key.
       Sheets of the workbook are listed on the combobox and listbox. We will use this listbox to add and delete worksheets.
With combobox can be navigated between sheets of the workbook. If selected any sheet from combobox ,that sheet's tab is activated .
The following codes provides assigning the macro to excel add sheet key :
Sub Auto_Open()
Application.OnKey "{F9}", "Show"
End Sub
 Sub Show()
    UserForm1.Show
End Sub

The created codes is following to list worksheets name on listbox and combobox :
...
Dim sayfa As Integer
    For sayfa = 1 To Sheets.Count
        ListBox1.AddItem Sheets(sayfa).Name
        ComboBox1.AddItem Sheets(sayfa).Name
    Next sayfa
....


excel vba add sheet


Read more ...

Excel Copy Unique Values To Other Sheet

Excel VBA Copy Unique Values


           In our template , unique values in Column A are found with VBA codes :
With Sheets("Sheet1")
    .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
...
End With

Later ,the found unique values in Column A are copied and listed in Column A of the other worksheet :
With Sheets("Sheet1")
...
  .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy Sheets("Sheet2").Range("A1")
  .ShowAllData
End With


excel vba copy unique values

All of the VBA codes in Module1:
Sub Unlikecopy()
With Sheets("Sheet1")
    .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy Sheets("Sheet2").Range("A1")
    .ShowAllData
End With
End Sub

The following codes are used to call the Unlikecopy () procedure with the button in Sheet1:
Private Sub CommandButton1_Click()
Call Unlikecopy
End Sub


excel vba copy unique values

Read more ...

Excel VBA Random Coloring The Duplicate Values

Excel VBA Highlight Duplicate Values

       
excel highlight duplicate values

          Sample workbook contains two sheet and different two example macro.Dictionary Collection Object was used in each two macro - Set Evn = CreateObject("Scripting.Dictionary") -

➥ In first example(Example1 Sheet) ago,the used range columns are sorted ascending according to cell A2 .The used codes :
ActiveSheet.Cells(2, Cells(Rows.Count, lst_column).End(xlUp).Row).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom 

Later duplicate values background are filled by same color (according to the desired colors) . Color index number can be selected between 1 to 56. This numbers are assigned to array :
Set Evn = CreateObject("Scripting.Dictionary")
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Not Evn.exists(Cells(i, 1).Value) Then
Colors = Array(2, 4, 6, 7, 8, 12, 15, 16, 17, 19, 20, 22,24, 27, 28, 33, 34, 35, 36, 37, 38, 39, 42, 43, 44, 45, 46, 48)
Clr = Colors(Int((UBound(Colors) - LBound(Colors) + 1) * Rnd))
 Range(Cells(i, 1), Cells(i, lst_column)).Interior.ColorIndex = Clr
            Evn.Add Cells(i, 1).Value, 1
                Else
            Range(Cells(i, 1), Cells(i, lst_column)).Interior.ColorIndex = Clr
        End If
Next i

➥ In second example(Example2 Sheet) , only duplicate values' background in Column A are filled by same color . Unique value's background color doesn't change (white color).

excel highlight duplicate values with random colors



Read more ...

Excel Animation Macro - Rotating Text

Excel Rotating Text Animation


Shape (WordArt Text) on the worksheet turns 360 degree. In module, our codes that ensure to turn 360 degree :

Sub Animasyon2()
  ActiveSheet.Shapes("WordArt 1").Select
    For i = 1 To 36
    Selection.ShapeRange.IncrementRotation 10#
    DoEvents
  Next i
  [A1].Select
End Sub

excel text animation




Read more ...

Calculating Days Between Two Dates - 2

Subtracting The Today's Date From Cell Date And Viewing Result In Cell Comment

          In this study, we have used the same template again. When the button on userform is clicked  , today's date is subtracted from the date in cell. Result can be viewed on the added comment in cell.

Example :  20.10.2017 - 21.09.2016 (Today's date) = 394 days

excel calculating days

VBA codes to add comment :
Private Sub CommandButton1_Click() 'Comments are added
Application.ScreenUpdating = False
CommandButton2_Click                     'To delete If cell has comment
On Error Resume Next
For Each cell In Sheets("liste").Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
cell.AddComment
cell.Comment.Visible = True
cell.Comment.Shape.Select
cell.Comment.Shape.TextFrame.AutoSize = True
cell.Comment.Text Text:=CStr(DateDiff("d", Date, cell.Value))
Next

Call create_comment_shape
Application.ScreenUpdating = True
Range("A1").Activate
End Sub


Read more ...

Excel VBA Calculating Days Between Two Dates

Calculating Days Between Date In Cell And Today 

            On userform ,days can be calculated until date in cell from today's date. Related codes :
.. TextBox15.Value = DateDiff("d", Date, Cells(ActiveCell.Row, 1).Value)
If Not IsDate(Cells(ActiveCell.Row, 1)) Then
TextBox15.Value = "Incorrect Value !"
End If
...





Read more ...

Excel Adding Item To Listbox And Combobox

Excel VBA From Textbox To Listbox & Combobox


           We conducted the processes without using the worksheet only on the userform in this sample.

With button on the userform, item can be added from textbox to combobox and to listbox .Also item in listbox can be updated and can be deleted with buton.


The listbox contains 13 columns. Therefore we have used an array to fill the listbox :
"...
myarr = Array(cmbBtch.Value, txtBtchNo.Value, cmbSupCode.Value, txtSupName.Value, txtDate.Value, _
cmbItmCode.Value, txtItmName.Value, txtBox.Value, txtTara.Value, txtGwght.Value, txtTtara.Value, txtNwght.Value, txtPrice.Value) V lstStItems.ColumnCount = 13
If lstStItems.ListCount <= 0 Then
lstStItems.Column = myarr
Else
lstStItems.AddItem myarr(0)
For n = 1 To 12
lstStItems.List(lstStItems.ListCount - 1, n) = myarr(n) V Next n
...
"


With an other button ,text boxes and combo boxes can be filled with listbox selected item's value :
"
...
If lstStItems.ListIndex <> -1 Then
With lstStItems
cmbBtch.Value = .List(.ListIndex, 0)
txtBtchNo.Value = .List(.ListIndex, 1)
cmbSupCode.Value = .List(.ListIndex, 2)
txtSupName.Value = .List(.ListIndex, 3)
txtDate.Value = .List(.ListIndex, 4)
cmbItmCode.Value = .List(.ListIndex, 5)
txtItmName.Value = .List(.ListIndex, 6)
txtBox.Value = .List(.ListIndex, 7)
txtTara.Value = .List(.ListIndex, 8)
txtGwght.Value = .List(.ListIndex, 9)
txtTtara.Value = .List(.ListIndex, 10)
txtNwght.Value = .List(.ListIndex, 11)
txtPrice.Value = .List(.ListIndex, 12)
End With
Else
MsgBox " Any listbox item isn't selected !", vbCritical, ""
End If
...
"

excel add item to listbox combobox


Read more ...

Excel Vba :Copy The Listbox Items Into Closed Workbook

VBA Copy Data To The Selected Sheet Of The Closed Workbook


        We have used address book template as sample in this tutorial.

List of the listbox or listbox item can be copied into other closed workbook with a button.


Is pressed "Copy Listbox" button , sheets of the closed workbook are listed in the drop-down list. Codes to list sheets of the closed workbook on combobox control :
Sub add_sheets()
Dim m As Byte
Workbooks.Open (ThisWorkbook.Path & "\Database.xls")
        For m = 1 To Sheets.Count
        UserForm2.ComboBox1.AddItem Sheets(m).Name
         Next m
    ActiveWorkbook.Close True
 UserForm2.ComboBox1.Enabled = True
End Sub

For convenience, we put both workbooks in the same folder. Our workbooks ;
📗 address_book_listbox_copy.xls  (workbook with userform)
📗 Database.xls  (the workbook from which the copying was made)


✔️ So that ,user can copy the contents of the listbox to the selected sheet.

excel copy data to closed workbook

All of the codes we used for copying (Copy Listbox button on userform) :
Private Sub CommandButton10_Click()
Application.ScreenUpdating = False
If ListBox1.ListCount = 0 Then
MsgBox "No items that will be copied.", vbCritical, ""
Exit Sub
End If
Call add_sheets

If ComboBox1.Value = "" Then
MsgBox "Please Choose A WorkSheet From Drop-Down List ", vbInformation, ""
ComboBox1.SetFocus
Exit Sub
End If

Workbooks.Open (ThisWorkbook.Path & "\Database.xls")
Sheets(ComboBox1.Value).UsedRange.Cells.Clear
Sheets(ComboBox1.Value).Range("A2:L" & ListBox1.ListCount + 1) = ListBox1.List
Sheets(ComboBox1.Value).Columns.AutoFit
ActiveWorkbook.Close True
MsgBox "The Listbox Records Were Copied.", vbInformation, ""
ComboBox1.Clear
ComboBox1.Enabled = False
Application.ScreenUpdating = True
End Sub



Read more ...

Compare Two Columns In Different Worksheets & Add Found Results

VBA Worksheet Function : CountIf


           Two columns in different worksheets were compared in this template.That is, column A of Page1 compared with column A of Page2.
The found different results as entire row were copied to second worksheet (Page2). 

✔️ Also new row or rows were highlighted .

excel vba compare two columns

Our VBA codes:
Sub compare_columns()
Dim stk, msb As Worksheet
Set stk = Sheets("Page1")
Set msb = Sheets("Page2")

Application.ScreenUpdating = False
sat = (msb.Range("A" & Rows.Count).End(xlUp).Row) + 1
For i = 2 To stk.Range("A" & Rows.Count).End(xlUp).Row
    If WorksheetFunction.CountIf(msb.Range("A2:A" & msb.Range("A" & Rows.Count).End(xlUp).Row), stk.Cells(i, "A")) = 0 Then
        msb.Range("a" & sat).EntireRow.Value = stk.Range("a" & i).EntireRow.Value
        msb.Range("a" & sat).Interior.ColorIndex = 22
        sat = sat + 1
    End If
Next
Application.ScreenUpdating = True
Set stk = Nothing: Set msb = Nothing
End Sub



Read more ...

Excel VBA Find And Delete

Excel Find & Delete Macro


           In this sheet, the value that you want to delete is found with macro.

With the opened msgbox ,found value's address is reported ,and you are asked whether you want to delete.
If you click "Yes" button on the msgbox, the row that contain value is deleted as whole.

Xlpart was selected  as the search method of "Find Method":

Set bul = Range(Cells(3, 1), Cells(Cells(Rows.Count, 1)._
End(xlUp).Row, LastColumn)).Find(WhatToFind, LookAt:=xlPart)

The macro searchs the value since the third row, because first row is empty and second row is header row.



Read more ...

Searching A Value Across An Entire Workbook With Userform

Excel Find A Value In Workbook With Userform - Reporting The Results



A great userform example for searching data on the selected sheet or the entire workbook.

      As an alternative to Excel Ctrl + F window, this userform can be used. In this template ; unlike from data searching with Ctrl + F, the found results are saved to the created a report sheet(ReportSheet).


Also ,for the found results, are created hyperlinks when they are clicked that gone to cell address with this procedure :
Sub Create_Hyperlinks()
Dim LArray() As String, a As Long
For a = 2 To Sheets("ReportSheet").Cells(Rows.Count, 1).End(xlUp).Row
     ActiveSheet.Hyperlinks.Add Anchor:=Range(Cells(a, 1), Cells(a, 2)), Address:="", SubAddress:=Cells(a, 1) & "!" & Cells(a, 1).Offset(0, 1)
    Next a
 End Sub

Firstly, when the userform opens, the sheets of the workbook are automatically listed in the drop-down list (VBA combobox control) :
Dim i As Byte
UserForm2.ComboBox1.AddItem "ALL SHEETS"
For i = 1 To Worksheets.Count
         UserForm2.ComboBox1.AddItem Worksheets(i).Name
    Next i

➥ Using textbox on userform ,data can be searched  in the selected sheet from the combobox or in all sheets as a part or as a whole.
The found results are listed on a listbox control. User can navigate between the items of the listbox by VBA spin button control .

Private Sub SpinButton1_SpinDown()
On Error Resume Next
If ListBox1.ListIndex = ListBox1.ListCount - 1 Then Exit Sub
With Me.ListBox1
        .ListIndex = .ListIndex + 1
    End With
 End Sub
Private Sub SpinButton1_SpinUp()
On Error Resume Next
If ListBox1.ListIndex = 0 Then Exit Sub
With Me.ListBox1
        .ListIndex = .ListIndex - 1
End With
End Sub

➥ When the selected item on the listbox is clicked,can be went to item's cell address.



Read more ...

Filter Between Two Dates With Userform

Excel Filter Between Two Dates Using ADODB Recordset


            In this example ,the records between two dates were filtered  with userform. Also filtered data can be copied to other sheet with a button.


We made the filtering between dates by using Adodb.Connection and Adodb.Recordset method. 


excel filter between two dates adodb

Read more ...

Filtering Between Two Specific Dates In Excel

Filling Combobox With Uniqe And Ascending Order Dates

            We ago have  created combo boxes containing  dates that unique ascending order sorted . For this process we have used Ado Connection. The dates in Column B were populated into two combo boxes.



             Later we've done filtering by the selected dates from drop-down lists with buttons.

We have added the following code to enter only date (as "dd.mm.yyyy") in the Column B :
"Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range, rng2 As Range
      If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    If Target.Address = "$B$1" Then Exit Sub
    For Each rng2 In Range(Target.Address)
    If rng2.Value = "" Then
    MsgBox "You Must Enter A Valid Date (20.10.2015 etc.)", vbCritical, ""
    rng2.Activate
    Exit Sub
    End If
        If IsDate(rng2.Value) = False Then
         rng2 = Empty
        Exit Sub
        Else
            rng2.Value = CDate(rng2)
        End If
    Next rng2

Read more ...