使用帶有條件的 VBA 將值從一張紙復制到另一張紙

Question

我的sheet_one看起來像這樣：

    2019-12-31
A   2
B   3
C   10

我的sheet_two看起來像這樣：

   2019-12-31  2020-01-31  2020-02-29  2020-03-31  2020-04-30  2020-05-31  2020-06-30  2020-07-31  2020-08-31  2020-09-30  2020-10-31  2020-11-30  2020-12-31
A                                                   
B                                                   
C                                                   

我的目標是將值從sheet_one復制到sheet_two ，其中日期匹配，以便sheet_two看起來像這樣：

   2019-12-31  2020-01-31  2020-02-29  2020-03-31  2020-04-30  2020-05-31  2020-06-30  2020-07-31  2020-08-31  2020-09-30  2020-10-31  2020-11-30  2020-12-31
A  2                                                   
B  3                                                 
C  10                                                 

在我將sheet_one中的日期sheet_one為2020-02-29並在sheet_one使用相同的值運行腳本但更改日期后， sheet_two將如下所示：

   2019-12-31  2020-01-31  2020-02-29  2020-03-31  2020-04-30  2020-05-31  2020-06-30  2020-07-31  2020-08-31  2020-09-30  2020-10-31  2020-11-30  2020-12-31
A  2                       2                            
B  3                       3                          
C  10                      10                           

我嘗試過的：

Sub test()

    Dim rngDate As Range, rngLetter As Range
    Dim dDate As Date
    Dim LastRow As Long, LastColumn As Long, i As Long, y As Long
    Dim Letter As String, strValue As String

    With ThisWorkbook.Worksheets("Sheet1")

        'Let as assume that Column A includes the letters. Find LastRow
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        'Let as assume that Row 1 includes the Dates. Find LastColumn
        LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        'Test if there available Dates
        If LastColumn > 1 Then
            'Test if there available Letters
            If LastRow > 1 Then
                'Loop Dates
                For i = 2 To LastColumn
                    'Set dDate
                    dDate = .Cells(1, i).Value
                    'Loop Letters
                    For y = 2 To LastRow
                        'Set Letter
                        Letter = .Cells(y, 1).Value
                        'Set Value to import
                        strValue = .Cells(y, i).Value
                        'Search in Sheet2
                        With ThisWorkbook.Worksheets("Sheet2")
                            'Let as assume that Row 1 includes the Dates
                            'Search for the dDate in Row 1
                            Set rngDate = .Rows(1).Find(What:=dDate, LookIn:=xlValues, lookat:=xlPart)
                            'Check if date found
                            If Not rngDate Is Nothing Then
                                'Search for the Letter in Column A
                                Set rngLetter = .Columns(1).Find(What:=Letter, LookIn:=xlValues, lookat:=xlPart)

                                If Not rngDate Is Nothing Then
                                    'Import Value
                                    .Cells(rngLetter.Row, rngDate.Column).Value = strValue
                                Else
                                    MsgBox "Letter not found"
                                End If

                            Else
                                MsgBox "Date not found"
                            End If

                        End With

                    Next y

                Next i

            End If

        End If

    End With

但我得到：

MsgBox "未找到日期"

我的錯誤在哪里或者這個問題有更好的解決方案嗎？

謝謝你的建議。

Answer 1

例如：您在 sheet1 中的數據為@Naresh Bhople 的圖片

在sheet2中：您的標題范圍= B1：H1，然后可以使用此代碼

Sub Test()
Dim Rng_Header As Range: Set Rng_Header = Sheets("sheet2").[B1:H1]
Dim Ws1 As Worksheet: Set Ws1 = Sheets("Sheet1")
Dim index_column As Variant
    index_column = Application.Match(Ws1.[B1], Rng_Header, 0)    'find index column in Rng_Header
    If IsError(index_column) Then MsgBox ("does not exist date"): Exit Sub
    ''find rng_data then set ít value
    Rng_Header.Offset(1, index_column - 1).Resize(3, 1).Value2 = Ws1.[B2:B4].Value2
End Sub

Answer 2

如果您希望它在 sheet1 更改時自動發生，您可以使用 Worksheet_Change 設置它

Sub test()

ThisWorkbook.Activate

Dim wS1 As Worksheet
Dim wS2 As Worksheet
Dim sourceRng As Range
Dim sourceCopyRng As Range
Dim targetRng As Range
Dim targetPasteRng As Range

Set wS1 = ThisWorkbook.Worksheets("Sheet1")
Set wS2 = ThisWorkbook.Worksheets("Sheet2")

Set sourceRng = wS1.Range("B1")
Set sourceCopyRng = wS1.Range("B2", Range("B" & Rows.Count).End(xlUp))
On Error Resume Next
Set targetRng = wS2.Range("1:1").Find(sourceRng.Value)
    If targetRng Is Nothing Then
    MsgBox "Date you entered couldn't be found in Sheet2 First Row"
    Exit Sub
    End If
Set targetPasteRng = targetRng.Offset(1, 0)

sourceCopyRng.Copy targetPasteRng

End Sub