列必须包含值；如果是，则该值的列偏移量必须包含另一个值

Question

这是我第一次写问题，因此，如果我的帖子令人困惑和/或需要更多详细信息，请原谅。

正如主题标题所建议的那样，我遇到了从必须满足多个条件的范围中提取某些值的问题。

Sub entryRetrieve()
'entryRetrieve - Macro to retrieve data from a certain range in the 'data 
 sheet' based on values from the entry sheet

'Defined worksheets'
Dim dataWS As Worksheet: Set dataWS = Worksheets("DATA")
Dim entryWS As Worksheet: Set entryWS = Worksheets("Indtastningsark")

'Defined values which is chosen based on a drop down menu in the 'entry sheet' '
Dim Initials As String: Initials = entryWS.Range("Initialer").Value
Dim Month As Long: Month = entryWS.Range("Måned").Value

'Ranges where copied values from the retrieved data hopefully should be placed'
Dim Tasks As Range: Set Tasks = entryWS.Range("J15:L24")
Dim Percentages As Range: Set Percentages = entryWS.Range("L15:L24")

'Function to sort through data in 'dataWS' and find if values exists. If yes, copy the range offset to the rows'
'This basically isn't working :( '
For Each cell In dataWS.Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    If cell.Value = Month Then
        If cell.Offset(0, -1).Value = Initials Then
            MsgBox "found"
            'Copy the following 11 rows'
            Else
            MsgBox "Initials not found"
        End If
    End If
Next

End Sub

所以我希望以书面形式发生的是；基于给定的值“初始值”和“月”，函数分别在“ A”列和“ B”列中找到它。在这两个值存在（并匹配）的行中，该函数复制“ C”，“ D”和“ E”列中包含的值，并将其粘贴到另一张工作表中已定义的“任务”范围内。

所附图片-绿色为值'initials'和'month';蓝色将被复制。

Picture of data

Picture of where data has to be pasted

希望您能理解我的问题。如果没有，请询​​问：）

Answer 1

下面是对代码的重新编写，做了一些小的更改。我在代码中留下了一些注释，以提供有关更改原因或行内容的一些信息。

简要说明；我声明了用于检查您的值的变量，LastRow的使用方式与以前相同，但是出于可读性考虑，我更喜欢在变量中使用它。两张纸都是一样的（但在我的测试中，我使用了Sheet2和Sheet3），最后是一个数组，用于“复制”您的范围，并提供一些范围变量用于循环和“粘贴”到目标。

为了测试，我将设置值分配给Month和Initials。

我在声明中加入了一些内容，再次是为了提高可读性。

您的For Each...Loop很好，当我运行它时返回了预期的结果。我怀疑当您尝试使用它时，您的值可能实际上不是您期望的值，因为当我期望它时，我得到了每个MsgBox（我还在调试消息中包含了一些额外的信息）。

代替Copy和Paste并不是最有效的函数，我有一个循环遍历B列中的每一行，以数字格式查找月份-（一月= 1，二月= 2，依此类推。 ）-如果找到下一个条件语句，则在A列中查找字符串“ SE”。

如果月份正确但字符串不匹配，则触发MsgBox "Initials not found on row: " & Cell.Row，但是如果它们匹配，则为CopyRange分配范围C6:E17中的值。

然后创建Destination，从范围的左上角单元格开始，然后动态调整大小以适合数组值。然后将数组写入Destination范围。

该数组遍历每一行，然后向下到下一行。请参阅下面的代码以获取示例输入和输出屏幕截图。

代码

Sub CAJTest()

Dim Month As Long
Dim Initials As String
Dim LastRow As Long

Dim entryWS As Worksheet
Dim dataWS As Worksheet
Set entryWS = Sheet3 '<~~ assign your correct sheet here
Set dataWS = Sheet2  '<~~ assign your correct sheet here

Dim CopyRange As Variant 'To be used as an array for our values.
Dim Destination As Range
Dim Cell As Range
Dim Tasks As Range

Month = 6
Initials = "SE"
LastRow = dataWS.Range("B" & Rows.Count).End(xlUp).Row 'I prefer to assign the last row to a variable

With dataWS
    For Each Cell In .Range("B2:B" & LastRow) 'I feel this is more readable than the above to find the last row being in this statement
        If Cell.Value = Month Then
            If Cell.Offset(0, -1).Value = Initials Then
                MsgBox "found " & Month & " and " & Initials & " on row: " & Cell.Row
                'the next line creates an array CopyRange with dimensions 1 to 12, 1 to 3 and assigns the values to the array
                CopyRange = .Range(.Cells(Cell.Row, Cell.Offset(0, 1).Column), .Cells(Cell.Offset(11, 0).Row, Cell.Offset(0, 3).Column)) 'Can also be written as Range("C" & Cell.Row, "E" & Cell.Row + 11)
                With entryWS
                    Set Destination = .Range("J15") 'Define top left cell of our destination
                    Set Destination = Destination.Resize(UBound(CopyRange, 1), UBound(CopyRange, 2)) 'Resize it per the bounds of our array
                    Destination.Value = CopyRange 'write the array to our newly resized destination range
                End With
            Else
                MsgBox "Initials not found on row: " & Cell.Row
            End If
        End If
    Next
End With

End Sub

屏幕截图

C，D和E列中的值代表单元地址。

从J15开始到调整大小的目标的预期输出