select 如果满足条件，则复制并粘贴到另一个单元格中的范围

Question

Dim word As Variant
Dim range As Variant


If cells(5, [6]) = "Bulk Density" Then
range = ("A3:K11")


For Each word In range
        If word = "Moisture Content" Then
            [M20] = word.Offset(0, 1)
            Exit For
        End If
        Next
        End If
End Sub

Hi im trying to select a range based on cell f5 . And then if that word is met in f5 i want to select a certain range ( A3:K11 ) where i can copy data from and move it to another cells. For example if cells f5 contains "Bulk density" i then want to copy the moisture content value in the range of cells (which is not always in the same row) and then paste the value into M20 . The copy and paste of the value works when i put the range in automatically but when i want it select the range itself the word variable is always empty and im not sure why. Any help would be greatly appreicated thanks max

Answer 1

A Kind of LookUp

• The first Sub addresses your immediate case ( Bulk Density... ).
• If you want to apply the same logic to other 'properties', edit the third Sub (which is calling the second Sub) to fit your needs.

The Code

Option Explicit

Sub writeValueConst()

    Const CheckString As String = "Bulk Density"
    Const CheckCellAddress As String = "F6"
    Const Searchstring As String = "Moisture Content"
    Const SearchRangeAddress As String = "F3:F11"
    Const ColumnOffset As Long = 1
    Const WriteCellAddress As String = "M20"
    
    Dim cel As Range
    If Range(CheckCellAddress).Value = CheckString Then
        For Each cel In Range(SearchRangeAddress).Cells
            If cel.Value = Searchstring Then
                Range(WriteCellAddress).Value _
                  = cel.Offset(0, ColumnOffset).Value
                Exit For
            End If
        Next cel
    End If

End Sub

Sub writeValue(ByVal CheckString As String, _
               ByVal CheckCellAddress As String, _
               ByVal Searchstring As String, _
               ByVal SearchRangeAddress As String, _
               ByVal WriteCellAddress As String, _
               Optional ByVal ColumnOffset As Long = 1)

    Dim cel As Range
    If Range(CheckCellAddress).Value = CheckString Then
        For Each cel In Range(SearchRangeAddress).Cells
            If cel.Value = Searchstring Then
                Range(WriteCellAddress).Value _
                  = cel.Offset(0, ColumnOffset).Value
                Exit For
            End If
        Next cel
    End If

End Sub

Sub writeDensities()
    Dim Series(1) As Variant
    
    ' If you add or remove, you have to adjust the previous number after Series.
    Series(0) = Array("Bulk Density", "F6", "Moisture Content", _
                      "F3:F11", "M20", 1)
    Series(1) = Array("Dry Density", "F8", "Degree of Compaction", _
                      "F3:F11", "M21", 1)
    
    Dim j As Long
    For j = 0 To UBound(Series)
        writeValue Series(j)(0), Series(j)(1), Series(j)(2), _
                   Series(j)(3), Series(j)(4), Series(j)(5)
    Next j

End Sub