Question

我的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                                                   
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中的日期更改为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

使用条件将VBA中的值从一张纸复制到另一张纸

2 个答案: