Блог

Извините, довольно общий вопрос, но не могу найти похожих вопросов, действительно дающих то, что мне нужно.

Мне нужно перенести дату с листа X на лист 7. На листе значение даты хранится в столбце C и объединяется по нескольким строкам, в которых на эту дату работает более 1 сотрудника. Сотрудники указаны в столбце E. Это значение в столбце E — «Имя, фамилия, отчество». Мне нужно скопировать дату с листа X на лист 7, где место, куда она должна попасть, находится в столбце P в строке, где идентификатор конкретного сотрудника находится в столбце C.

Весь этот процесс начинается с выбора ячейки «Имя-фамилия» на листе, а идентификаторы состоят из 7 чисел. Я смог настроить это достаточно, чтобы перестать получать какие-либо ошибки, но это не работает:

 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
 

Тогда кое-что, что я еще не рассмотрел, — это небольшая обработка ошибок. Идентификатор всегда должен быть на листе 7, и у меня есть небольшой страх перед пробелом в начале «Имя и фамилия идентификатора».

Поиск в VBA с объединенными ячейками ( 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
 

Так что немного поиграл с этим. Добавление 1 к результату матча теперь дает мне правильную строку для листа 7. Использовал LTrim, чтобы избавиться от начальных пробелов, и добавил небольшую обработку ошибок, которая соответствует моим потребностям.

 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