Sunday, 30 September 2012

Excel VBA Macro For a Special Task

Excel VBA Macro For a Special Task

Sub MyTasks()

Dim D As String
Dim M As String
Dim Y As String

Dim a As Integer
Dim b As Integer
Dim c As Integer

Dim I As String
Dim J As String
Dim F As String
Dim P As Variant
Dim W As Worksheet

On Error Resume Next
Application.DisplayAlerts = False

I = MsgBox("Do You Wish To Run Macro", vbOKCancel)
If I = vbCancel Then GoTo TPR

D = Day(Date)
M = Month(Date)
Y = Year(Date)

c = 1

F = D & "-" & M & "-" & Y

Workbooks(F).Close
Workbooks(F).Delete
MkDir "C:\Documents and Settings\Administrator\My Documents\" & "TeamTasks"
P = "C:\Documents and Settings\Administrator\My Documents\TeamTasks\"
Workbooks.Add.SaveAs (P & F & ".xlsx")
Workbooks(F).Sheets(1).Name = "TaskSheet"

J = InputBox("Enter Task Book Name ", "My Task Book Name", "Enter Here...")

Workbooks(J).Activate

For Each W In Workbooks(J).Worksheets
W.Activate
For a = 4 To 500

If Cells(a, 11) <> "" Or Cells(a, 12) <> "" Or Cells(a, 13) <> "" Or _
Cells(a, 14) <> "" Or Cells(a, 15) <> "" Or Cells(a, 16) <> "" Or _
Cells(a, 17) <> "" Or Cells(a, 18) <> "" And Cells(a, 1) <> "" Then
c = c + 1

Workbooks(F).Sheets("TaskSheet").Cells(c, 1) = W.Cells(a, 1)
Workbooks(F).Sheets("TaskSheet").Cells(c, 2) = W.Name

For b = 14 To 17
Workbooks(F).Sheets("TaskSheet").Cells(c, 3) = Workbooks(F).Sheets("TaskSheet").Cells(c, 3) + W.Cells(a, b)
Next b

Workbooks(F).Sheets("TaskSheet").Cells(c, 4) = W.Cells(a, 13)
Workbooks(F).Sheets("TaskSheet").Cells(c, 5) = _
Workbooks(F).Sheets("TaskSheet").Cells(c, 3) - Workbooks(F).Sheets("TaskSheet").Cells(c, 4)
Workbooks(F).Sheets("TaskSheet").Cells(c, 6) = Workbooks(F).Sheets("TaskSheet").Cells(c, 5) * 0.175

End If

Next a
c = c + 1
Next W

Workbooks(F).Save
Workbooks(F).Close

TPR:
End Sub

No comments:

Post a Comment

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts