在两列中搜索单词，然后复制到另一张纸上

Question

在我的问题中：

1. 首先，我需要在B列中找到“单元名称”。
2. 如果找到“单元名称”，则应在D列中查找“名字：”并向右复制5个单元格。 （I10中的“奥巴马”）
3. 将“奥巴马”这个名称粘贴到“单位名称”表中。 （将“奥巴马”粘贴到表格“ 1” A1）

我是编码新手，所以我对此不太了解。我尝试了一些代码，但是效率不高。

这是一张显示我的问题的图像。

Sub Test()

    Dim i As Integer
    Dim m As Integer
    Dim n As Integer
    Dim z As Integer

    For i = 1000 To 1 Step -1
        If Range("B" & i).Value = "Unit Name" Then
            m = 2
            m = i + 1
            n = i - 18

            If Range("D" & n).Value = "First Name:" Then
                m = Range("B" & m).Value + 1
                Range("H" & n).Copy
                Sheets(m).Range("B7").PasteSpecial xlPasteValues
            End If
        End If
    Next i

End Sub

Answer 1

您不需要所有这些整数变量，而可以使用一些Range变量：

Sub find_name()
Dim mainWS As Worksheet, altWS As Worksheet
Dim unitCel As Range, fNameCell As Range

Set mainWS = Worksheets("Sheet2") 'CHANGE AS NEEDED
Set altWS = Worksheets("Sheet1")

With mainWS
    Set unitCel = .Range("B:B").Find(What:="Unit Name")
    If Not unitCel Is Nothing Then
        Set fNameCell = .Range("D:D").Find(What:="First Name:").Offset(0, 5)
        altWS.Range("A1").Value = fNameCell.Value
    End If
End With

End Sub

根据数据的位置，可能需要进行调整。我假设“奥巴马”可以是任何文本，在D列右边三列，其中找到“ First Name：”。

Answer 2

 Sub Shift_Over5()
Dim i As Long
'Sheet name should be a string
Dim SheetName As String
Dim FirstName As Range
Dim UnitName As Range
'Dim l As Byte --> I changed it to lUnitSheetLastrow, because we need to copy the data from sheet1 to sheet 1,2...
' then you need to check the last row of unit sheet and write data to the last row + 1.
Dim lUnitSheetLastrow As Long
Dim FirstMatch As Variant

Dim Start
Start = VBA.Timer

For i = 1 To 40000 Step 1
    'For clear code and easy to follow, you need to mention the sheet you want to interact
    'Here i use 'Activesheet', i assume that the current sheet is sheet1
    If ActiveSheet.Range("A" & i).Value = "Unit Name" Then
        ' i think we dont need this code line, because we identified the cell in column B has value is "Unit Name"
        'Set UnitName = Range("A:A").Find(what:="Unit Name")
        ' Here you dont need to use Offset
        'SheetName = UnitName.Offset(1, 0).Value
        SheetName = ActiveSheet.Range("A" & (i + 1)).Value
        ' Find "First Name" in 20 rows in column E.
        ' What happen if i<20, the nextline will show the error, because the minimum row is 1
        If i < 40 Then
            Set FirstName = ActiveSheet.Range("D1" & ":D" & i).Find(what:="First Name:")
        Else
            Set FirstName = ActiveSheet.Range("D" & i & ":D" & (i + 40)).Find(what:="First Name")
        End If
        ' make sure the SheetName is not empty and Unit sheet is existing in you workbook then copy the first name to  unit sheet
        If SheetName <> "" And CheckWorkSheetAvailable(SheetName) Then
            ' Check the first name is not nothing
            If Not FirstName Is Nothing Then
                'Check if the cell B7 in unit sheet empty or not
                If Worksheets(SheetName).Range("H7").Value = "" Then
                    'if empty, write to B7
                    Worksheets(SheetName).Range("H7").Value = FirstName.Offset(1, 0).Value
                Else
                    'else, Find the lastrow in column D of unit sheet
                    lUnitSheetLastrow = Worksheets(SheetName).Cells(Worksheets(SheetName).Rows.Count, 1).End(xlUp).Row
                    'Write data to lastrow +1
                    Worksheets(SheetName).Range("A" & (lUnitSheetLastrow + 1)).Value = FirstName.Offset(, 1).Value
                End If

            End If

        End If
    'You forgot to put end if here
    End If
Next i
Debug.Print Round(Timer - Start, 3)
End Sub

Function CheckWorkSheetAvailable(SheetName As String) As Boolean
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
    If ws.Name = SheetName Then
        CheckWorkSheetAvailable = True
        Exit For
    End If
Next

End Function

谢谢大家，我找到了答案。