VBA에 대한 일치 및 복사 기능 생성 시도

일치로 복사 / 바꾸기

• 상수 섹션의 값을 조정하고 워크 시트를 다시 확인하십시오.

코드

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("*" & cValue & "*", 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