Sorry, a pretty generic question, but can't find similiar questions really getting at what I need.

I need to move a date from Sheetx to Sheet7. On Sheetx the date value is stored in the C column and is merged across mulitple rows where there is more than 1 employee against that date. Employees are in column E. That value in column E is "ID FirstName Surname". I need to copy the date from Sheetx to Sheet7, where the location it needs to go is in column P on the row where that specific employee's ID is in Column C.

This process all starts with selecting the "ID FirstName Surname" cell on Sheetx, and IDs are 7 numbers long. I've been able to tweak this enough to stop getting any errors, but it isn't working:

Sub StartDateToDataSheet()
  Dim i, ActiveRow, DataRow, EmpID As Long, StartDate As Date
  EmpID = Left(ActiveCell.Value, 7)
  DataRow = Application.Match(EmpID, Sheet7.Range("C2:C699"), 0)
  ActiveRow = ActiveCell.Row
  For i = ActiveRow To 6 Step -1
    If Cells(i, 3) <> "" Then
      StartDate = Cells(i, 3)
      Exit For
    End If
  Next i
  Sheet7.Cells(DataRow, 16) = StartDate
End Sub

Then something I haven't considered yet is a little error handling. The ID should always be on Sheet7, and I have a slight fear of a space at the beginning of " ID FirstName Surname".

CodePudding user response：

VBA Lookup with Merged Cells (Find)

Option Explicit

Sub StartDateToDataSheet()
' s - Source (SheetX) - only read from
' d - Destination (Sheet7) - read from and written to
' l - Lookup (ID)
' v - Value (Date)

    Const slFirst As String = "E2"
    Const svCol As String = "C"
    
    Const dlFirst As String = "C2"
    Const dvCol As String = "P"
    Const dvNotFound As Variant = "Nope"
  
    Dim sws As Worksheet: Set sws = SheetX
    Dim dws As Worksheet: Set dws = Sheet7
    
    Dim slrg As Range: Set slrg = RefColumn(sws.Range(slFirst))
    If slrg Is Nothing Then Exit Sub ' no data in source lookup column
    Dim sllCell As Range: Set sllCell = slrg.Cells(slrg.Cells.Count)
    
    Dim dlrg As Range: Set dlrg = RefColumn(dws.Range(dlFirst))
    If dlrg Is Nothing Then Exit Sub ' no data in destination lookup column
    
    'Debug.Print slrg.Address(0, 0), dlrg.Address(0, 0)
    
    Dim slCell As Range
    Dim svCell As Range
    Dim dlCell As Range
    Dim dvCell As Range
    
    For Each dlCell In dlrg.Cells
        Set slCell = slrg.Find(Trim(CStr(dlCell.Value)), _
            sllCell, xlFormulas, xlPart)
        Set dvCell = dlCell.EntireRow.Columns(dvCol)
        If slCell Is Nothing Then ' not found
            dvCell.Value = dvNotFound
        Else ' found
            Set svCell = slCell.EntireRow.Columns(svCol)
            If svCell.MergeCells Then ' merged
                dvCell.Value = svCell.MergeArea(1).Value
            Else ' not merged
                dvCell.Value = svCell.Value
            End If
        End If
    Next dlCell
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row   1)
    End With

End Function

CodePudding user response：

So played around with it a little. Adding a 1 to the match result is now giving me the correct row for Sheet7. Used LTrim to get rid of leading spaces, and added a little error handling that suits my needs.

Sub StartDateToDataSheet()
  On Error GoTo eh
  Dim i, DataRow, ActiveRow, EmpID As Long, StartDate As Date
  EmpID = Left(LTrim(ActiveCell.Value), 7)
  DataRow = Application.Match(EmpID, Sheet7.Range("C2:C699"), 0)   1
  ActiveRow = ActiveCell.Row
  For i = ActiveRow To 6 Step -1
    If Cells(i, 3) <> "" Then
      StartDate = Cells(i, 3)
      Exit For
    End If
  Next i
  Sheet7.Cells(DataRow, 16) = StartDate
Done:
  Exit Sub
eh:
  MsgBox "ID not found in data sheet"
End Sub