Искать слова в двух столбцах и копировать на другой лист

Question

В моей задаче:

1. Сначала мне нужно найти «Имя подразделения» в столбце B.
2. Если он нашел «Имя устройства», он должен найти «Имя:» в столбце D и скопировать 5 ячеек справа. («Обама» в I10)
3. Вставьте имя "Обама" на лист имени подразделения. (Вставить «Обама» в лист «1» А1)

Я новичок в кодировании, поэтому я не слишком много знаю об этом. Я пытался с некоторыми кодами, но это не эффективно.

Вот изображение, показывающее мою проблему.

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

 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

спасибо всем, что нашел ответ.

Answer 2

Вам не нужны все эти целочисленные переменные, вместо этого вы можете использовать несколько 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, где находится «Имя:».