Wednesday, June 22, 2016

To do list made by VBA



Diwnload:
https://www.dropbox.com/s/bc2i4p98zs5zrf7/To_do_list.xlsm?dl=0

It's like this.

Code:
Private Sub AddButton_Click()

Application.ScreenUpdating = False
Rows("5:5").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("5:5").RowHeight = 15
Range("A5:E5").Font.Bold = False
Range("C5") = Date
Range("D5") = "ongoing"
    With Range("E5")
        .HorizontalAlignment = xlLeft
    End With
Range("E5").WrapText = True

Application.ScreenUpdating = True

End Sub

Private Sub DoneButton_Click()

Application.ScreenUpdating = False

Call Inserter("done", 4, 2)

Application.ScreenUpdating = True

End Sub

Private Sub SuspendBtn_Click()

Dim CurrentRow As Integer

Application.ScreenUpdating = False

Call Inserter("suspended", 4, 1)

Application.ScreenUpdating = True

End Sub

Sub Inserter(ByVal str As String, ByVal FRnum As Integer, ByVal Color As Integer)

Dim RowNum As Integer
RowNum = ActiveCell.Row
Dim StrFRNumber As String
StrFRNumber = "D" & FRnum & ":D" & FRnum
Dim ColNum As Integer
Dim LastCol As Integer
If Range(StrFRNumber) = Empty Then
    MsgBox "Select an event to be moved as """ & str & """"
    Exit Sub
Else
    LastRow = Range(StrFRNumber).End(xlDown).Row
    LastCol = Range(StrFRNumber).End(xlToRight).Column
    Dim i As Integer
    For i = 1 To LastRow
        If Range("C" & i).Value = "----" Then
            LastRow = i + 1
            Exit For
        End If
    Next i
End If
If RowNum < FRnum + 1 Then
    MsgBox "Select an event to be moved as """ & str & """"
    Exit Sub
ElseIf RowNum >= LastRow - 1 Then
    MsgBox "Select an event to be moved as """ & str & """"
    Exit Sub
ElseIf ActiveCell.Column > LastCol Then
    MsgBox "Select an event to be moved as """ & str & """"
    Exit Sub
End If
Range("D" & RowNum) = str
Dim RangeToBeMoved As String
RangeToBeMoved = "A" & RowNum & ":" & "E" & RowNum

If Color = 1 Then
    With Range(RangeToBeMoved).Interior
        .Color = 65535
        .TintAndShade = 0
    End With
ElseIf Color = 2 Then
    With Range(RangeToBeMoved).Interior
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249977111117893
    End With
End If

Dim RowNum2 As String
RowNum2 = RowNum & ":" & RowNum
Rows(RowNum2).Cut

Dim RangeLast As String
RangeLast = LastRow & ":" & LastRow
Rows(RangeLast).Insert Shift:=xlDown
Range("A1").Select

End Sub