Tuesday, February 28, 2017

Convert Numeric Value To Words In Userform Excell VBA







Private Sub TextBox1_Change()

On Error Resume Next

If Me.TextBox1.Text <> "" Then

Me.TextBox2.Text = SpellNumber(Me.TextBox1.Text)

Else

Me.TextBox2 = ""

End If

End Sub

Monday, February 27, 2017

Play Youtube Video IN Userform EXcell VBA





Private Sub CommandButton1_Click()

Me.ShockwaveFlash1.Movie = "https://www.youtube.com/v/acIOtfweCXY&vq=hd720"

Me.ShockwaveFlash1.AllowFullScreen = True

End Sub

Saturday, February 25, 2017

Transfer Data One Sheet TO Multiple Sheets Excell VBA





Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

Dim i As Long

For i = 2 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))

b = Application.WorksheetFunction.CountA(Sheet2.Range("A:A")) + 1

For x = 2 To 5

For c = 0 To 3

Sheets("Sheet" & x).Range("A" & b).End(xlToLeft).Offset(0, c).Value = _

Sheet1.Cells(i, c + 1).Value

Next c

Next x

Next i

Application.ScreenUpdating = True

End Sub

Thursday, February 23, 2017

Filter Database With Customer Name In Worksheet Excell VBA





Private Sub ComboBox1_Change()

Dim i As Long

Sheet1.Range("A2:F1000").ClearContents

For i = 2 To Application.WorksheetFunction.CountA(Sheet2.Range("A:A"))

c = Application.WorksheetFunction.CountA(Sheet1.Range("A:A")) + 1

For x = 1 To 6

If Sheet2.Cells(i, 1).Value = Me.ComboBox1.Value Then

Sheet1.Range("A" & c).End(xlToLeft).Offset(0, x - 1).Value = Sheet2.Cells(i, x).Value

End If

Next x

Next i

Sheet1.Range("G2").Value = Application.WorksheetFunction.Sum(Sheet1.Range("F:F"))

End Sub

Friday, February 17, 2017

Transfer Data To worksheet And Count Days Excell VBA



Combobbox Fill
Private Sub UserForm_Initialize()
Dim i As Long
For i = 2 To Application.WorksheetFunction.CountA(Sheet2.Range("A:A"))
Me.ComboBox1.AddItem Sheet2.Cells(i, 1).Value
Next i
End Sub
Textbox Format
Private Sub TextBox1_AfterUpdate()
On Error Resume Next
Me.TextBox1 = CDate(Me.TextBox1)
End Sub
Private Sub TextBox2_AfterUpdate()
On Error Resume Next
Me.TextBox2 = CDate(Me.TextBox2)
End Sub
Data Transfer To Sheet
Private Sub CommandButton1_Click()
Dim x As Long
x = Application.WorksheetFunction.CountA(Sheet1.Range("A:A")) + 1
Sheet1.Range("A" & x).Value = Me.ComboBox1.Value
Sheet1.Range("B" & x).Value = Me.TextBox1.Text
Sheet1.Range("C" & x).Value = Me.TextBox2.Text
On Error Resume Next
Sheet1.Range("D" & x).Value = Sheet1.Range("C" & x) - Sheet1.Range("B" & x) & "Days"
End Sub

Thursday, February 16, 2017

Searching Telephone Directory Excell VBA



VBA Code

Private Sub TextBox1_Change()
On Error Resume Next
Me.TextBox1.Text = StrConv(Me.TextBox1.Text, vbProperCase)
Me.ListBox1.Clear
Dim i As Long
For i = 2 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
For x = 1 To 4
a = Len(Me.TextBox1.Text)
If Left(Sheet1.Cells(i, x).Value, a) = Me.TextBox1.Text And Me.TextBox1.Text <> "" Then
Me.ListBox1.AddItem Sheet1.Cells(i, 1).Value
For c = 1 To 4
Me.ListBox1.List(ListBox1.ListCount - 1, c) = Sheet1.Cells(i, c + 1).Value
Next c
End If
Next x
Next i

End Sub


New Code With Capture Column Heds Data

Private Sub UserForm_Initialize()
Me.TextBox1.SetFocus
End Sub

Private Sub TextBox1_Change()
On Error Resume Next
Me.TextBox1.Text = StrConv(Me.TextBox1.Text, vbProperCase)
Me.ListBox1.Clear
Me.ListBox1.AddItem Sheet1.Cells(1, "A")
For B = 2 To 4
Me.ListBox1.List(ListBox1.ListCount - 1, B - 1) = Sheet1.Cells(1, B)
Next B
Me.ListBox1.Selected(0) = True
Dim i As Long
For i = 2 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
For x = 1 To 4
a = Len(Me.TextBox1.Text)
If Left(Sheet1.Cells(i, x).Value, a) = Me.TextBox1.Text And Me.TextBox1.Text <> "" Then
Me.ListBox1.AddItem Sheet1.Cells(i, 1).Value
For c = 1 To 4
Me.ListBox1.List(ListBox1.ListCount - 1, c) = Sheet1.Cells(i, c + 1).Value
Next c
End If
Next x
Next i
End Sub

Wednesday, February 15, 2017

Worksheet Data Edit From Userform EXcell VBA





Textbox Format
Private Sub TextBox1_AfterUpdate()
On Error Resume Next
Me.TextBox1 = CDate(Me.TextBox1)
End Sub
Private Sub TextBox3_AfterUpdate()
On Error Resume Next
Me.TextBox3.Value = StrConv(Me.TextBox3.Value, vbProperCase)
End Sub
Private Sub TextBox4_AfterUpdate()
On Error Resume Next
Me.TextBox4.Value = Format(Me.TextBox4.Value, "#####.00")
End Sub
Worksheet To Userform
Private Sub TextBox5_AfterUpdate()
Dim i As Long
For i = 2 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
For x = 1 To 4
If Sheet1.Cells(i, "B").Value = Me.TextBox5.Text Then
Me("Textbox" & x).Value = Sheet1.Cells(i, x).Value
End If
Next x
Next i
End Sub
Userform To worksheet
Private Sub CommandButton1_Click()
Dim i As Long
For i = 2 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
For x = 1 To 4
If Sheet1.Cells(i, "B").Value = Me.TextBox5.Text Then
Sheet1.Cells(i, x).Value = Me("Textbox" & x).Value
End If
Next x
Next i
End Sub

Tuesday, February 14, 2017

Worksheet Sum Runningbalance Excell VBA





Private Sub Worksheet_Change(ByVal Target As Range)
 i = Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
On Error Resume Next
Sheet1.Cells(i, "D").Value = Val(Sheet1.Cells(i - 1, "D")) + Val(Sheet1.Cells(i, "B")) _
- Val(Sheet1.Cells(i, "C"))
End Sub

Monday, February 13, 2017

Worksheet Send Data Without Duplicate Value In EXcell VBA





Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
For i = 2 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
a = Application.WorksheetFunction.CountIf(Sheet1.Range("B:B"), _
Sheet1.Cells(i, 1).Value)
If a = 0 Then
Sheet1.Range("B1000000").End(xlUp).Offset(1, 0).Value = Sheet1.Cells(i, 1).Value
End If
Next i
End Sub

Sunday, February 12, 2017

Insert serial Number Automatically In Wortksheet Excell VBA





Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
i = Application.WorksheetFunction.CountA(Sheet1.Range("B:B"))
If i > 1 Then
Sheet1.Range("A" & i).Value = i - 1
End If
End Sub

Saturday, February 11, 2017

Processor Bar In Userform Excell VBA





Private Sub CommandButton1_Click()

Dim i As Long

For i = 1 To 5000 Step 3

Me.Label2.Width = Me.Label2.Width + 0.3

DoEvents

Me.Caption = i / 50 & "%"

Me.Label2.Caption = i / 50 & "%"

If Me.Label2.Width >= 300 Then

Me.Label2.BackColor = vbYellow

End If

Next i

Me.Caption = "Completed"

Me.Label2.Caption = "Completed"

Me.Label2.TextAlign = fmTextAlignCenter

End Sub

Friday, February 10, 2017

Combobox Additem From worksheet Dynamic Range Excell VBA





Combobox Fill Dynamic Range
Private Sub UserForm_Initialize()
Dim i As Long
For i = 1 To Sheet1.Range("A1000000").End(xlUp).Offset(1, 0).Row
Me.ComboBox1.AddItem Sheet1.Cells(i, 1).Value
Next i
End Sub

Thursday, February 9, 2017

Listbox Additem From Worksheet Between Two Date Excell VBA





Private Sub TextBox1_AfterUpdate()
On Error Resume Next
Me.TextBox1 = CDate(Me.TextBox1)
End Sub

Private Sub TextBox2_AfterUpdate()
On Error Resume Next
Me.TextBox2 = CDate(Me.TextBox2)
Me.ListBox1.Clear
For i = 2 To Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
If Sheet1.Cells(i, 1).Value >= CDate(Me.TextBox1.Value) And _
Sheet1.Cells(i, 1).Value <= CDate(Me.TextBox2.Value) Then
Me.ListBox1.AddItem Sheet1.Cells(i, 1).Value
Me.ListBox1.List(ListBox1.ListCount - 1, 1) = Sheet1.Cells(i, 2).Value & ".00"
End If
Next i
End Sub

Tuesday, February 7, 2017

Calendar In Excell VBA Useerform





For Combobox & Textbox
Private Sub UserForm_Initialize()
Me.TextBox1.Value = Format(Date, "YYYY")
For i = 0 To 11
a = Application.WorksheetFunction.EDate("1" & "/" & "January" & "/" & Me.TextBox1.Value, i)
Me.ComboBox1.AddItem Format(a, "MMMM")
Next i
Me.ComboBox1.Value = Format(Date, "MMMM")
End Sub
Private Sub TextBox1_Change()
Call ComboBox1_Change
End Sub
For Spinbutton
Private Sub SpinButton1_SpinDown()
On Error Resume Next
Me.TextBox1.Value = Me.TextBox1.Value - 1
End Sub
Private Sub SpinButton1_SpinUp()
On Error Resume Next
Me.TextBox1.Value = Me.TextBox1.Value + 1
End Sub
For Listbox
Private Sub ComboBox1_Change()
Me.ListBox1.Clear
For i = 1 To 31
On Error Resume Next
Me.ListBox1.AddItem CDate(i & "/" & Me.ComboBox1.Value & "/" & Me.TextBox1.Value)
Me.ListBox1.List(ListBox1.ListCount - 1, 1) = Format(CDate(i & "/" & _
Me.ComboBox1.Value & "/" & Me.TextBox1.Value), "DDDD")
Next i
End Sub


Monday, February 6, 2017

Listbox Capture From Other Workbook Excell VBA Userform





Private Sub UserForm_Initialize()
Dim database As Workbook, i As Long
Application.ScreenUpdating = False
Set database = Workbooks.Open(ThisWorkbook.Path & "/" & "Database.xlsm")
For i = 2 To Application.WorksheetFunction.CountA(Sheets("Sheet1").Range("A:A"))
Me.ListBox1.AddItem Sheets("Sheet1").Cells(i, 1).Value
Me.ListBox1.List(ListBox1.ListCount - 1, 1) = Sheets("Sheet1").Cells(i, 2).Value
Next i
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub

Sunday, February 5, 2017

Listbox Get sum Monthly total from Worksheet Excell VBA





Combobox Fill
Private Sub UserForm_Initialize()
For i = 0 To 3
Me.ComboBox1.AddItem Format(Date, "YYYY") - i
Next i
Me.ComboBox1.Value = Format(Date, "YYYY")
End Sub
Listbox Fill
Private Sub ComboBox1_Change()
Me.ListBox1.Clear
For i = 0 To 11
A = Application.WorksheetFunction.EDate("1" & "/" & "January" & "/" & Me.ComboBox1.Value, i)
B = Application.WorksheetFunction.EoMonth("1" & "/" & "January" & "/" & Me.ComboBox1.Value, i)
Me.ListBox1.AddItem Format(A, "MMMM")
Me.ListBox1.List(ListBox1.ListCount - 1, 1) = Application.WorksheetFunction.SumIfs _
(Sheet1.Range("B:B"), Sheet1.Range("A:A"), _
">=" & A, Sheet1.Range("A:A"), "<=" & B)
Next i
End Sub

Saturday, February 4, 2017

Listbox Additem From Other Listbox Excell VBA





VBA Code

Private Sub CommandButton1_Click()
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then
Me.ListBox2.AddItem Me.ListBox1.Column(0)
Me.ListBox1.Selected(i) = False
End If
Next i
End Sub

Friday, February 3, 2017

Multiple Listbox Additem From worksheeet Excell VBA





VBA Code

Private Sub UserForm_Initialize()
Dim i As Long
For i = 1 To Application.WorksheetFunction.CountA(Sheet1.Range("A:C"))
For x = 1 To 3
Me("listbox" & x).AddItem Sheet1.Cells(i, x).Value
Me("listbox" & x).Selected(0) = True
Next x
Next i
End Sub