将值从一个工作表移动到另一个工作表

Question

对不起，这是一个很普通的问题，但是我找不到类似的问题。

我需要将日期从Sheetx移动到Sheet7。在Sheetx上，日期值存储在C列中，并跨多个行合并，其中针对该日期有超过1名员工。雇员在E列，E列的值为"ID FirstName姓"。我需要将日期从Sheetx复制到Sheet7，其中它需要去的位置在行P列中，特定员工的ID在c列中。

这个过程都是从选择"ID FirstName姓氏"开始的。单元格，id长度为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

那么我还没有考虑到的是一点错误处理。ID应该总是在Sheet7上，我有点担心"开头的空格。ID FirstName姓"

Answer 1

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

Answer 2

所以稍微摆弄一下。向匹配结果添加+ 1现在为Sheet7提供了正确的行。使用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