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 ...