Find The Repeated Data On The Sheet With Count Of Repetitions

        As sample, data in Column A was used in this Excel VBA Template.

When the button is pressed,the repeated data in "Column A" are listed  into "Column G" and "Column H" with the count of repetitions.

Our codes :

Sub repeating_data()
Dim t As Object, sonsat As Long, liste(), j As Long
    sonsatir = Cells(Rows.Count, "A").End(xlUp).Row
    Range("F2:H" & Rows.Count).ClearContents
    liste = Range("A2:A" & sonsatir).Value
    Set t = CreateObject("scripting.dictionary")
    For j = 1 To UBound(liste)
        If Not t.exists(liste(j, 1)) Then
            t.Add liste(j, 1), 1
        Else
            t.Item(liste(j, 1)) = t.Item(liste(j, 1)) + 1
        End If
    Next j
    Application.ScreenUpdating = False
    Range("G2").Resize(t.Count, 2) = Application.Transpose(Array(t.keys, t.Items))
        Range("G2:H" & Rows.Count).Sort Range("H2"), xlDescending
     Call number_of_repetitions
    Application.ScreenUpdating = True
End Sub

Read more ...

Show Only One Column

Show Only The Selected Column With Dropdown List

          Suppose you have a worksheet with a lot of columns. There are headers in Column A, other columns of sheets have data.
You want column A to remain constant, and you want to see one by one next to column A to examine the other columns.

         We have prepared a userform for this purpose.We've added a combobox and toggle button to Excel userform.
The column selected from the Combobox in the userform is displayed next to column A, the other columns are hidden.

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 ToggleButton1_Click()
ComboBox1.Value = ""
ActiveSheet.Cells.EntireColumn.Hidden = False
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
ToggleButton1.Value = False
 End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        ActiveSheet.Cells.EntireColumn.Hidden = False
    End If
End Sub

Read more ...

Excel Number To Text Function

Convert A Numeric Value To Dollar & Cents Currency

       
          A useful Excel function.
We created a NumbertoText function in VBA Module1. Our function converts the number to dollars and cents currency.
The function can be used on all worksheets of the workbook.

For example, enter "75,30" into cell G1, and enter the following formula into A1 cell:
=NumbertoText(G1)
The result will be as this in A1 cell : Seventy Five Dollars and Thirty Cents

Codes of our function :

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

If you wish, you can use different currencies in the function.

Read more ...

Copy & Paste Macro

Excel VBA Copy & Paste 

           B7,C7,D7 and E7 cells in Invoice sheet are copied into blank rows in the Data sheet.

Our VBA codes that we used in the template:

Private Sub CommandButton1_Click()
Dim son As Long

If Sheets("Invoice").Range("B7") = "" Or Sheets("Invoice").Range("C7") = "" Or _
Sheets("Invoice").Range("D7") = "" Or Sheets("Invoice").Range("E7") = "" Then MsgBox "Missing Data", _
vbCritical: Exit Sub
son = Sayfa1.Range("A" & Rows.Count).End(xlUp).Row
Sheets("Data").Cells(son + 1, 1) = Sheets("Invoice").Range("B7")
Sheets("Data").Cells(son + 1, 2) = Sheets("Invoice").Range("C7")
Sheets("Data").Cells(son + 1, 3) = Sheets("Invoice").Range("D7")
Sheets("Data").Cells(son + 1, 4) = Sheets("Invoice").Range("E7")
MsgBox "Registration Successful", vbApplicationModal
Sheets("Invoice").Range("B7:E7").ClearContents
Sheets("Data").Activate
End Sub

We used this code to find the first blank cell in column A  and we assigned it to "son" variable :

son = Sayfa1.Range("A" & Rows.Count).End(xlUp).Row

Read more ...