Modifying Existing VBA Code to add 2 additional data columns

K

keranali

Rules Violation
Joined
Oct 4, 2010
Messages
234
Office Version
  1. 365
Platform
  1. Windows
Good Day I have an excel to do task work book however I need to insert 2 additional columns and have them automated in the existing code below hwo can I achieve this?

VBA Code: 
Public OldDate As Date

Private Sub chkHelp_Click()
    
    Dim Obj As Object
    
    Set Obj = shTask.Shapes("Help")
    
    If chkHelp.Value = True Then
    
        Obj.Visible = True
    Else
    
        Obj.Visible = False
    
    End If
    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  
  'if Date entered directly in L8 (Activities Date)
    If Target.Column = 12 And Target.Row = 8 Then
    
        If Target.Value <> OldDate And IsDate(shTask.Range("L8").Value) Then
        
                iConfirmation = MsgBox("Do you want to change the date?", vbQuestion + vbYesNo + vbDefaultButton2, "Confirmation")
                
                If iConfirmation = vbYes Then
            
                   Call UpdateTask_and_Refresh
                   
                   OldDate = ThisWorkbook.Sheets("To-Do List").Range("L8").Value
                    
                End If
            
        End If
    End If
    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim iConfirmation As VbMsgBoxResult
       
    OldDate = ThisWorkbook.Sheets("To-Do List").Range("L8").Value
    
    'If Date Selection is from Calendar

    If Target.Column >= 2 And Target.Column <= 8 And checkCalendar.Value = True Then
    
        If (Target.Row >= 12 And Target.Row <= 17) Or (Target.Row >= 21 And Target.Row <= 26) Then
            
            'Validating whether user has selected the same date again
            
            If Target.Value <> OldDate Then
        
                iConfirmation = MsgBox("Do you want to change the date?", vbQuestion + vbYesNo + vbDefaultButton2, "Confirmation")
                
                If iConfirmation = vbYes Then
                
                    Application.EnableEvents = False
                    ThisWorkbook.Sheets("To-Do List").Range("L8").Value = Target.Value
                    Call UpdateTask_and_Refresh
                    Application.EnableEvents = True
                    
                End If
            
            End If
            
        
        End If
        
    End If
    
End Sub

Sub GetNewTask()
    
    Application.EnableEvents = False
    
    Dim iRow As Long
    Dim dActivityDate As String
    
    ThisWorkbook.Sheets("To-Do List").Range("K11:R100").ClearContents
    
    iRow = ThisWorkbook.Sheets("Master List").Range("B" & Rows.Count).End(xlUp).Row + 1
    
    'Assign Current Date to Date Variable
    
    ThisWorkbook.Sheets("Master List").Range("B2:B" & iRow).NumberFormat = "d-mmm-yy"
    
    
    dActivityDate = Format(ThisWorkbook.Sheets("To-Do List").Range("L8").Value, "d-mmm-yy")
    
    
    'Remove filter from Master List worksheet
    
    ThisWorkbook.Sheets("Master List").AutoFilterMode = False
    
     
    ThisWorkbook.Sheets("Master List").Range("A1:H" & iRow).AutoFilter Field:=2, Criteria1:=dActivityDate
    
    ThisWorkbook.Sheets("Master List").Range("A1:H" & iRow).AutoFilter Field:=5, Criteria1:=Array("In Progress", "Not Started", "="), Operator:=xlFilterValues
    
    On Error Resume Next
    
    ThisWorkbook.Sheets("Master List").Range("C2:H" & iRow).SpecialCells(xlCellTypeVisible).Copy
    
    ThisWorkbook.Sheets("To-Do List").Range("K11").PasteSpecial xlPasteValues
    
    Application.CutCopyMode = False
    
    ThisWorkbook.Sheets("To-Do List").Range("J10").Select

    'Remove filter from Database worksheet
    
    ThisWorkbook.Sheets("Master List").AutoFilterMode = False
    
    ThisWorkbook.Sheets("To-Do List").Activate
    
    Application.EnableEvents = True
    
End Sub


Sub UpdateTask_and_Refresh()


   'Validating if date has been selected or not
    
   If Trim(shTask.Range("L8").Value) = "" Or Not (IsDate(shTask.Range("L8").Value)) Then
   
    MsgBox "Activities Date is Blank/Incorrect. Please enter the valid date ", vbCritical + vbOKOnly, "Error!"
   
    shTask.Range("L8").Select
    Exit Sub
   
   End If

    
    Dim iRow As Long
    Dim iMaster As Long
    Dim iLastRow As Long
    
    iRow = 11
    
    'Loop in To do List Sheet
    Do While shTask.Cells(iRow, 11).Value <> ""
        
      iMaster = 2
      
      'Code to update data in Master list sheet
      'Loop in Master List sheet
      Do While shMasterList.Cells(iMaster, 8).Value <> ""
      
      'To check if key is matching
      
        If shMasterList.Cells(iMaster, 8).Value = shTask.Cells(iRow, 16).Value Then
        
           shMasterList.Cells(iMaster, 4).Value = shTask.Cells(iRow, 12).Value
           shMasterList.Cells(iMaster, 5).Value = shTask.Cells(iRow, 13).Value
           shMasterList.Cells(iMaster, 6).Value = shTask.Cells(iRow, 14).Value
           
           'Remarks
           If shMasterList.Cells(iMaster, 5).Value = "Completed" Then
           
            shMasterList.Cells(iMaster, 7).Value = shTask.Cells(iRow, 15).Value & " Completed On - " & [Text(Now(), "DD-MMM-YYYY HH:MM:SS")]
            
           Else
           
           shMasterList.Cells(iMaster, 7).Value = shTask.Cells(iRow, 15).Value
           
           End If
           
           
        End If
        
        iMaster = iMaster + 1
      
      Loop
      
      
      'identifying the last row in Master List
      iLastRow = shMasterList.Range("A" & Application.Rows.Count).End(xlUp).Row + 1
      
      'Update the Task in Master List if that is new entries and no key
      If Trim(shTask.Cells(iRow, 16).Value) = "" Then
      
        shMasterList.Cells(iLastRow, 1).Value = shMasterList.Cells(iLastRow, 1).Row - 1 'S.No.
        shMasterList.Cells(iLastRow, 2).Value = shTask.Range("L8").Value 'Due Date
        shMasterList.Cells(iLastRow, 3).Value = shTask.Cells(iRow, 11).Value 'Task Name
        shMasterList.Cells(iLastRow, 4).Value = shTask.Cells(iRow, 12).Value 'Priority
        shMasterList.Cells(iLastRow, 5).Value = shTask.Cells(iRow, 13).Value 'Status
        shMasterList.Cells(iLastRow, 6).Value = shTask.Cells(iRow, 14).Value 'Deferred Date
        
        'Remarks
        If shMasterList.Cells(iMaster, 5).Value = "Completed" Then
        
         shMasterList.Cells(iMaster, 7).Value = shTask.Cells(iRow, 15).Value & " Completed On - " & [Text(Now(), "DD-MMM-YYYY HH:MM:SS")]
         
        Else
        
        shMasterList.Cells(iMaster, 7).Value = shTask.Cells(iRow, 15).Value
        
        End If
        
        
        shMasterList.Cells(iLastRow, 8).Value = "=RC[-7]&""|"" & RC[-6] &""|"" & RC[-5] & ""|"" & RC[-4]" 'Key
      
      End If
      
      'identifying the last row in Master List
      iLastRow = shMasterList.Range("A" & Application.Rows.Count).End(xlUp).Row + 1
      
      'For defrred, add a new records at the end of master list
      If shTask.Cells(iRow, 13).Value = "Deferred" Then
      
        shMasterList.Cells(iLastRow, 1).Value = shMasterList.Cells(iLastRow, 1).Row - 1 'S.No.
        shMasterList.Cells(iLastRow, 2).Value = shTask.Cells(iRow, 14).Value 'Due Date
        shMasterList.Cells(iLastRow, 3).Value = shTask.Cells(iRow, 11).Value 'Task Name
        shMasterList.Cells(iLastRow, 4).Value = shTask.Cells(iRow, 12).Value 'Priority
        shMasterList.Cells(iLastRow, 5).Value = "" 'Status
        shMasterList.Cells(iLastRow, 6).Value = "" 'Deferred Date
        shMasterList.Cells(iLastRow, 7).Value = "Deferred - " & shTask.Cells(iRow, 15).Value 'Remarks
        shMasterList.Cells(iLastRow, 8).FillDown 'Key
      
      End If
      
      
    
     iRow = iRow + 1
     
    Loop
    
    'Post updating the task in Master List, get the pending, in progress and blank Task from Master List to To Do List sheet
    
    Call GetNewTask

End Sub

Sub Update_On_Click()

    Dim iMsg As VbMsgBoxResult
    
    iMsg = MsgBox("Do you want to update and refresh the activities?", vbQuestion + vbYesNo, "Update & Refresh")
    
    If iMsg = vbNo Then Exit Sub
    
    Call UpdateTask_and_Refresh
    
End Sub


The original Spread sheet layout :

Daily Activities Tracker.xlsm
JKLMNO
10S. No.Task NamePriority StatusDeferred DateRemarks
111Apply leave for next monthLowCompletedDeffered -
122Send report to FrankHighCompletedDeferred -
133Prepare Weekly ReportHighIn ProgressDeferred -
144Finish PresentationHighIn ProgressDeferred -
155Develop Sales DashboardNormalCompletedDeferred - Working on this
166Approve report accessNormalDeferred29-Nov-23Deferred -
177Raise ticket to install SQLNormalCompletedDeferred -
188Mark attendanceHighDeferred30-Dec-23Deferred -
199Attend Team meetingHighNot StartedDeferred -
2010Apply leave for next monthLowNot StartedDeferred -
2111Send report to FrankHighCompletedDeferred -
2212Prepare Weekly ReportHighNot StartedDeferred -
2313Develop Sales DashboardNormalIn ProgressDeferred -
2414Approve report accessNormalIn ProgressDeferred -
2515Raise ticket to install SQLNormalIn ProgressDeferred -
26 
To-Do List
Cell Formulas
RangeFormula
J11:J26J11=IF(TRIM(K11)<>"", ROW()-10,"")
Cells with Conditional Formatting
CellConditionCell FormatStop If True
O11:O38Other TypeIcon setNO
Cells with Data Validation
CellAllowCriteria
L11:L38ListLow,Normal,High
M11:M38ListNot Started,In Progress,Deferred,Completed
J10Any value
K10Any value
L10Any value
M10Any value
N10Any value
O10Any value




The New layout with additional columns I want added:
Daily Activities Tracker.xlsm
JKLMNOPQ
10S. No.CustomerTask NameAsigneePriority StatusDeferred DateRemarks
111Apply leave for next monthLowCompletedDeffered -
122Send report to FrankHighCompletedDeferred -
133Prepare Weekly ReportHighIn ProgressDeferred -
144Finish PresentationHighIn ProgressDeferred -
155Develop Sales DashboardNormalCompletedDeferred - Working on this
166Approve report accessNormalDeferred29-Nov-23Deferred -
177Raise ticket to install SQLNormalCompletedDeferred -
188Mark attendanceHighDeferred30-Dec-23Deferred -
199Attend Team meetingHighNot StartedDeferred -
2010Apply leave for next monthLowNot StartedDeferred -
2111Send report to FrankHighCompletedDeferred -
2212Prepare Weekly ReportHighNot StartedDeferred -
2313Develop Sales DashboardNormalIn ProgressDeferred -
2414Approve report accessNormalIn ProgressDeferred -
2515Raise ticket to install SQLNormalIn ProgressDeferred -
26 
To-Do List
Cell Formulas
RangeFormula
J11:J26J11=IF(TRIM(L11)<>"", ROW()-10,"")
Cells with Conditional Formatting
CellConditionCell FormatStop If True
Q11:Q38Other TypeIcon setNO
Cells with Data Validation
CellAllowCriteria
N11:N38ListLow,Normal,High
O11:O38ListNot Started,In Progress,Deferred,Completed
J10:K10Any value
L10:M10Any value
N10Any value
O10Any value
P10Any value
Q10Any value


Master Sheet with updated columns:

Daily Activities Tracker.xlsm
BCDEFGHIJ
1Due DateCustomerTask NameAsigneePriority StatusDeferred DateRemarksKey (For Internal Use only)
222-Sep-23Mark attendanceHighCompleted1|45191|Mark attendance
322-Sep-23Attend Team meetingHighCompleted2|45191|Attend Team meeting
422-Sep-23Apply leave for next monthLowIn ProgressWorking on this3|45191|Apply leave for next month
522-Sep-23Send report to FrankHighCompletedWorking on this4|45191|Send report to Frank
622-Sep-23Prepare Weekly ReportHighCompletedDone5|45191|Prepare Weekly Report
722-Sep-23Finish PresentationHighCompletedWorking on this6|45191|Finish Presentation
822-Sep-23Develop Sales DashboardNormalCompletedWorking on this7|45191|Develop Sales Dashboard
922-Sep-23Approve report accessNormalCompletedDone8|45191|Approve report access
1022-Sep-23Raise ticket to install SQLNormalCompletedDone.9|45191|Raise ticket to install SQL
1122-Sep-23Register to ChatGPTLowDeferred28-Jan-23Will complete the registrion later10|45191|Register to ChatGPT
1222-Sep-23Mark attendanceHighCompleteddddd11|45191|Mark attendance
1322-Sep-23Attend Team meetingHighCompletedDone12|45191|Attend Team meeting
1422-Sep-23Apply leave for next monthLowCompletedsdafdf29-Oct-2023 20:15:3013|45191|Apply leave for next month
1522-Sep-23Send report to FrankHighWorking on this14|45191|Send report to Frank
1622-Sep-23Prepare Weekly ReportHighCompletedWorking on this15|45191|Prepare Weekly Report
1724-Oct-23Apply leave for next monthLowDeffered - 20|45223|Apply leave for next month
1822-Sep-23Develop Sales DashboardNormalWorking on this17|45191|Develop Sales Dashboard
1922-Sep-23Approve report accessNormalWorking on this18|45191|Approve report access
Master List
Cell Formulas
RangeFormula
J2:J19J2=A2&"|"&B2&"|"&D2
Cells with Conditional Formatting
CellConditionCell FormatStop If True
J2:J331Other TypeIcon setNO
I2:I331Other TypeIcon setNO
Cells with Data Validation
CellAllowCriteria
G1Any value
H1Any value
I1Any value
B1:C1Any value
D1:E1Any value
F1Any value
F2:F11ListLow,Normal,High


Support Sheet:

Daily Activities Tracker.xlsm
ABCDEF
1MonthTotal Task15
2Dec-23Blank0
3Jan-24Not Started3
4Feb-24In Progress5
5Mar-24Deferred2
6Apr-24Completed5
7May-24
8Jun-24
9Jul-24Total100%
10Aug-24Completed%33%
11Sep-24
12Oct-24
13Nov-24
14
15
16
17
18
19
20
21
22
Support Data
Cell Formulas
RangeFormula
F1F1=COUNTA('To-Do List'!$L$11:$L$502)
F2F2=COUNTIFS('To-Do List'!$L$11:$L$502,"<>"&"",'To-Do List'!$O$11:$O$502,"")
F3F3=COUNTIF('To-Do List'!$O$11:$O$502,E3)+F2
F4:F6F4=COUNTIF('To-Do List'!$O$11:$O$502,E4)
F9F9=IF(F1>0,1,0)
F10F10=IFERROR(F6/F1,0)
A2A2=EOMONTH(TODAY(),-2)+1
A3A3=EOMONTH(TODAY(),-1)+1
A4A4=EOMONTH(TODAY(),0)+1
A5A5=EOMONTH(TODAY(),1)+1
A6A6=EOMONTH(TODAY(),2)+1
A7A7=EOMONTH(TODAY(),3)+1
A8A8=EOMONTH(TODAY(),4)+1
A9A9=EOMONTH(TODAY(),5)+1
A10A10=EOMONTH(TODAY(),6)+1
A11A11=EOMONTH(TODAY(),7)+1
A12A12=EOMONTH(TODAY(),8)+1
A13A13=EOMONTH(TODAY(),9)+1
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
You must log in or register to reply here.

Similar threads

M
  • Question Question
Add in VBA Code to check zip code against pre-determined list
Replies
0
Views
405
mikefisher
M
B
  • Question Question
Excel VBA Searching Unique Variables to Match against Exported Schedule Files to Determine Date
Replies
1
Views
158
sijpie
sijpie
V
  • Question Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
523
VanGirl
V
D
  • Question Question
Using If Statement VBA to Submit to Additional Worksheet
Replies
4
Views
507
Micron
M
D
  • Locked
  • Question Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
329
RoryA
RoryA

Forum statistics

Threads
1,223,881
Messages
6,175,159
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top