find the value in range and if exist enter date in the same row in next available column cell

Prashant1211

New Member
Joined
Jun 9, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Dear all, I am trying to create a OTD list for projects dispatched. I have a excel application which is used to dispatch the project. So what i am trying is the OTD list (another workbook) should be updated with project name and dispatch date once the project is dispatched from the application. below is my code.
Problem i am facing is if the same project is dispatched again then code create one more entry in OTD list in next row rather then searching if the project already exist. and if the project already exist than it should add the next date in-front of the project in next available column (This is required because project is dispatched in n number of lots). and if not then should work as per below code.

Can someone please help me in this. Thanks for your support.

Sub OTD()
Dim x As Workbook
Dim LR As Integer
Dim answer As Integer

answer = MsgBox("Update OTD List?", vbQuestion + vbYesNo)

If answer = vbYes Then

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Sheets("Main Sheet").Range("B5").Copy 'project no. from main application copied
Set x = Workbooks.Open("File location OTD list") ' otd list open


LR = x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Row

x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Select

Selection.Value = Date

Selection.NumberFormat = "dd/mm/yyyy"

'Close x:
x.Save
x.Close

Else
End If

End Sub
 

Some videos you may like

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,514
Office Version
  1. 2013
Platform
  1. Windows
See if this works for you.

VBA Code:
Sub OTD()
Dim x As Workbook
Dim LR As Integer
Dim answer As Integer
answer = MsgBox("Update OTD List?", vbQuestion + vbYesNo)
    If answer = vbYes Then
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
        Set x = Workbooks.Open("File location OTD list") ' otd list open
            If Application.CountIf(x.Sheets("OTD").Range("A:A")) = 0 Then
                Sheets("Main Sheet").Range("B5").Copy 'project no. from main application copied
                LR = x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Row
                x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
                x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Date
               x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).NumberFormat = "dd/mm/yyyy"
               'Close x:
               x.Close True
           Else
              MsgBox "Project Number Already Exists in OTD list.", vbInformation, "ENTRY FOUND"
           End If
     End If
End Sub
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,713
Try:
VBA Code:
Sub OTD()
    Dim x As Workbook, fnd As Range, srcWS As Worksheet, lCol As Long
    Set srcWS = ThisWorkbook.Sheets("Main Sheet")
    If MsgBox("Update OTD List?", vbQuestion + vbYesNo) = vbYes Then
        Application.ScreenUpdating = False
        Set x = Workbooks.Open("File location OTD list") ' otd list open
        Set fnd = Sheets("OTD").Range("A:A").Find(srcWS.Range("B5").Value, LookIn:=xlValues, lookat:=xlWhole)
        If fnd Is Nothing Then
            srcWS.Range("B5").Copy
            With Sheets("OTD")
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Format(Date, "dd/mm/yyyy")
            End With
        Else
            With Sheets("OTD")
                lCol = .Cells(fnd.Row, Columns.Count).End(xlToLeft).Column + 1
                .Cells(fnd.Row, lCol) = Format(Date, "dd/mm/yyyy")
            End With
        End If
        x.Close True
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End If
End Sub
 

Prashant1211

New Member
Joined
Jun 9, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Hi
JLGWhiz

, Thanks for your reply but i want to search for the project no. in the list before copying it, if it exist then just put date in front of it (in the next available column) dont copy and if not found than copy it.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,713

ADVERTISEMENT

Try the macro I suggested in Post #3.
 

Prashant1211

New Member
Joined
Jun 9, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Thank you very much mumps, with small modifications your code worked well.

.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Select
Selection.Value = Date

Selection.NumberFormat = "dd/mm/yyyy"

End With
Else
With Sheets("OTD")
lCol = .Cells(fnd.Row, Columns.Count).End(xlToLeft).Column + 1
.Cells(fnd.Row, lCol).Select
Selection.Value = Date

Selection.NumberFormat = "dd/mm/yyyy"
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,713

ADVERTISEMENT

You are very welcome. :) My original code should have worked without your modifications. You don't have to select the cell to add the formatted date. Did my version not work for you?
 

Prashant1211

New Member
Joined
Jun 9, 2020
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
No it gave some error and when i modified as shown above it worked perfectly. Thanks a lot and I wish you a nice weekend.
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,514
Office Version
  1. 2013
Platform
  1. Windows
Just for continuity sake, here is a revised version.
VBA Code:
Sub OTD()
Dim x As Workbook
Dim LR As Integer
Dim answer As Integer
answer = MsgBox("Update OTD List?", vbQuestion + vbYesNo)
    If answer = vbYes Then
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
        Set x = Workbooks.Open(ThisWorkbook.Path & "\File location OTD list") ' otd list open
            If Application.CountIf(x.Sheets("OTD").Range("A:A"), ThisWorkbook.Sheets("Main Sheet").Range("B5")) = 0 Then
               ThisWorkbook.Sheets("Main Sheet").Range("B5").Copy 'project no. from main application copied
                LR = x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Row
                x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
                x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Date
               x.Sheets("OTD").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).NumberFormat = "dd/mm/yyyy"
               'Close x:
               x.Close True
           Else
              MsgBox "Project Number Already Exists in OTD list.", vbInformation, "ENTRY FOUND"
           End If
     End If
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,112,995
Messages
5,543,185
Members
410,584
Latest member
Bluefox68
Top