Блог

Я пытался создать код, но не смог завершить его, чтобы сопоставить G9 значение с ColE:E тем, что я описал ниже.

В файле Excel есть два листа, имя которых — Sheet1 и Sheet4 . Sheet1 имеет данные, и эти данные будут вставлены Sheet4 после сопоставления значения.

Sheet4.Range(«G9») = code сопоставит это значение с Sheet1.Диапазон («E:E») =

Если код совпадает, он скопирует данные, выделенные желтым цветом, до конца столбца и вставит в Sheet4.range(«G11») в качестве транспонирования.

любая помощь будет принята с благодарностью.

мой код

 Sub myfunc()


Dim Cell As Range

With Sheet1
      For Each Cell In .Range("E1:E" amp; .Cells(.Rows.Count, "E").End(xlUp).Row)
        If Cell.Value = Sheet4.Range("G9") Then

       'looking for method
        End If
    Next Cell
End With



End Sub
 

Копировать / транспонировать с помощью Match

• Отрегулируйте значения в разделе константы и дважды проверьте рабочие листы.

Код

 Option Explicit

Sub myCopyTranspose()
    
    ' Define constants.
    Const sFirstCell As String = "E7"
    Const sCopyFirstColumn As String = "D"
    Const dCriteriaCell As String = "G9"
    Const dFirstCell As String = "G11"
    
    ' Define Source Search (Column) Range and Row Offset.
    Dim rg As Range
    Dim cel As Range
    Dim RowOffset As Long
    With Sheet1.Range(sFirstCell)
        Set cel = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If cel Is Nothing Then Exit Sub ' no data
        Set rg = .Resize(cel.Row - .Row   1)
        RowOffset = .Row - 1
    End With
    
    ' Retrieve Criteria.
    Dim cValue As Variant: cValue = Sheet4.Range(dCriteriaCell).Value
    If IsError(cValue) Then Exit Sub ' error value
    If Len(cValue) = 0 Then Exit Sub ' empty or blank
    cValue = CStr(cValue)
    
    ' Find a match of Criteria in Source Search Range.
    Dim cMatch As Variant
    cMatch = Application.Match("*" amp; cValue amp; "*", rg, 0)
    If IsError(cMatch) Then Exit Sub ' no match
    
    ' Define Source Copy (Row) Range.
    With Sheet1.Cells(cMatch   RowOffset, sCopyFirstColumn)
        Set cel = Nothing
        Set cel = .Resize(, .Worksheet.Columns.Count - .Column   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If cel Is Nothing Then Exit Sub ' no data
        Set rg = .Resize(, cel.Column - .Column   1)
    End With
    
    ' Copy/Transpose Source Copy (Row) Range to Destination (Column) Range.
    Application.ScreenUpdating = False
    rg.Copy
    Sheet4.Range(dFirstCell).PasteSpecial _
        Paste:=xlPasteAll, _
        Transpose:=True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    ' Inform user.
    MsgBox "Data transferred.", vbInformation, "Success"

End Sub