基于行和列复制粘贴单元格

Question

我希望我的 sheet 做的是当用户更新 sheet“Buffy Cast”上的单元格 D3:D8 中的值时，他们可以按下按钮这些值将被复制到“实际 FTE”选项卡中。 “实际 FTE”选项卡有一个 table，其中包含多个日期和此人的 ID。代码应根据“Buffy Cast”sheet 中的日期找到列，然后找到行 ID，将数据复制到此位置。

我承认重新使用了一些字典代码来查找行，这确实有效，但我在查找列时遇到了问题。 Sheet下面的代码和代码，非常感谢。

验证Sheet

空白实际值Sheet

我希望实际情况发生什么 sheet

最后是我的代码

    Option Explicit

Sub Update()

    Dim wsValidate As Worksheet, wsActual As Worksheet
    Dim lrValidate As Long, lrActual As Long
    Dim i As Long, r As Long, rc As Variant
    Dim n As Long, m As Long

    Dim dict As Object, key As String
    Set dict = CreateObject("Scripting.Dictionary")
    

    Set wsValidate = Worksheets("BuffyCast")
    Set wsActual = Worksheets("ActualFTE")
    
    Dim sourceWS As Worksheet, targetWS As Worksheet
    Dim lastCol As Long, lastRow As Long, srcRow As Range
    Dim found1 As Range, j As Long, Cr1 As String
 'Find column
    With wsActual
        lastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
        For j = 1 To lastCol
        Cr1 = Worksheets("BuffyCast").Range("D2")
        Set srcRow = .Range("A2", .Cells(2, lastCol))
        Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)
        Next
    End With
 'Make dictionary
    With wsActual
        lrActual = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lrActual
            key = Trim(.Cells(i, "A"))
            If dict.exists(key) Then
                MsgBox "Duplicate ID No '" & key & "'", vbCritical, "Row " & i
                Exit Sub
            ElseIf Len(key) > 0 Then
                dict.Add key, i
            End If
        Next
    End With

    With wsValidate
        lrValidate = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lrValidate
            key = Trim(.Cells(i, "A"))
            If dict.exists(key) Then
                r = dict(key)
                wsActual.Cells(r, found1) = .Cells(i, "D")
                    n = n + 1
            Else
                .Rows(i).Interior.Color = RGB(255, 255, 0)
                m = m + 1
            End If
        Next
    End With
    MsgBox n & "Actual FTE Update" & vbLf & m & " rows not found", vbInformation
End Sub

Answer 1

您可以使用 WorksheetFunction.Match method 在一行中查找值：

Dim Col As Long
On Error Resume Next
Col = Application.WorksheetFunction.Match(wsValidate.Range("D2").Value2, wsActual.Rows(2), 0)
On Error GoTo 0

If Col = 0 Then
    MsgBox "Column was not found", vbCritical
    Exit Sub
End If

' here col has the column number you are looking for
' and you can write to that column like
wsActual.Cells(RowNumber, Col).Value = 123

这将在 wsActual 的第二行找到 wsValidate.Range("D2") 的值。

基于行和列复制粘贴单元格

Copy Paste a cell based on Row & Column

excel

vba