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

[Prashant1211]

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

 

[JLGWhiz]

See if this works for you.

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]

Try:

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]

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]

Try the macro I suggested in Post #3.

 

[Prashant1211]

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]

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]

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.

 

[mumps]

My pleasure.

 

[JLGWhiz]

Just for continuity sake, here is a revised version.

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