Хотите скопировать строки на основе ввода ячейки

Question

У меня есть этот код, который я использовал (не мой).Это хорошо работает со мной, потому что я знаю, что могу изменить значение в sh.Rows ("x") на любую строку, какую захочу, и она соберет все, что мне нужно.Я хочу сделать это проще для одного из моих коллег, чтобы им не пришлось заходить в Visual Basic для его редактирования.Есть ли простой способ сделать так, чтобы он мог взять любую строку, которая находится в ячейке B2, с каждого листа и вставить ее в мастер-лист?

Sub CopytoMaster()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    If SheetExists("Master") = True Then
        MsgBox "The sheet Master already exist"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set DestSh = Worksheets.Add
    DestSh.Name = "Master"
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            If sh.UsedRange.Count > 1 Then
                Last = LastRow(DestSh)
                sh.Rows("7").Copy DestSh.Cells(Last + 1, 1)
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub CheckMaster()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    If SheetExists("Master") = True Then
        MsgBox "The sheet Master already exist"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set DestSh = Worksheets.Add
    DestSh.Name = "Master"
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            If sh.UsedRange.Count > 1 Then
                Last = LastRow(DestSh)
                With sh.Rows("7")
                    DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
                    .Columns.Count).Value = .Value
                End With
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function Lastcol(sh As Worksheet)
    On Error Resume Next
    Lastcol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function
Function SheetExists(SName As String, _
                     Optional ByVal WB As Workbook) As Boolean
    On Error Resume Next
    If WB Is Nothing Then Set WB = ThisWorkbook
    SheetExists = CBool(Len(Sheets(SName).Name))
End Function

Answer 1

Это то, что у меня сейчас, и оно работает так, как я хочу.

Sub CopytoMaster2()
Dim wb As Workbook
Dim sh As Worksheet
Dim ws As Worksheet
Dim DestSh As Worksheet
Dim mainSh As Worksheet

Dim Last As Long
If SheetExists("Master") = True Then
    MsgBox "The sheet Master already exist"
    Exit Sub
End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"

Set wb = ActiveWorkbook
Set mainSh = wb.Sheets("Main")

For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> mainSh.Name And sh.Name <> DestSh.Name Then
        If sh.UsedRange.Count > 1 Then
            Last = LastRow(DestSh)
            sh.Rows(mainSh.Range("E7").Value).Copy DestSh.Cells(Last + 1, 1)
        End If
    End If
Next
Application.ScreenUpdating = True

End Sub

Sub CheckMaster2 () Dim wb As Workbook Dim sh As WorksheetDim ws As Worksheet Dim DestSh As Worksheet Dim mainSh As Worksheet Dim Last As Long, если SheetExists ("Master") = True, тогда MsgBox "Мастер листа уже существует", Exit Sub End If Application.ScreenUpdating = False Установить DestSh = Worksheets.Add DestSh.Name = "Master" Set wb = ActiveWorkbook Set mainSh = wb.Sheets ("Main")

For Each sh In ThisWorkbook.Worksheets
    If mainSh.Name <> sh.Name And sh.Name <> DestSh.Name Then
        If sh.UsedRange.Count > 1 Then
            Last = LastRow(DestSh)
            With sh.Rows(mainSh.Range("E7").Value)
                DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
                .Columns.Count).Value = .Value
            End With
        End If
    End If
Next
Application.ScreenUpdating = True

End Sub

Функция LastRow2 (sh As Worksheet) При ошибке Возобновить Следующая LastRow= sh.Cells.Find (Что: = "*", _ После: = sh.Range ("A1"), _ Lookat: = xlPart, _ LookIn: = xlFormulas, _ SearchOrder: = xlByRows, _ SearchDirection: = xlPrevious, _ MatchCase: = False) .Row On Error GoTo 0 Завершить функцию

Функция Lastcol2 (sh As Worksheet) В случае ошибки Resume Next Lastcol = sh.Cells.Find (What: = "*", _ After:= sh.Range ("A1"), _ Lookat: = xlPart, _ LookIn: = xlFormulas, _ SearchOrder: = xlByColumns, _ SearchDirection: = xlPrevious, _ MatchCase: = False). Столбец при ошибке GoTo 0 Завершить Функция Функция SheetExists2 (SName As String, _ Необязательный ByVal wb As Workbook) В качестве логического значения On Error Resume Next Далее, если wb нет ничего, затем установить wb = ThisWorkbook SheetExists =CBool ​​(Len (Sheets (SName). Name)) End Function

Answer 2

Вы можете просто использовать метод Range.Value, чтобы получить значение B2.Поместите это в метод .Row().Другими словами, вам просто нужно изменить sh.Rows("7") на sh.Rows(ws.range("B2").value).

Sub CopytoMaster()
    Dim sh As Worksheet, ws As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    If SheetExists("Master") = True Then
        MsgBox "The sheet Master already exist"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set DestSh = Worksheets.Add
    DestSh.Name = "Master"
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            If sh.UsedRange.Count > 1 Then
                Last = LastRow(DestSh)
                sh.Rows(ws.Range("B2").Value).Copy DestSh.Cells(Last + 1, 1)
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

То же самое с вашей второй процедурой:

Sub CheckMaster()

    Dim ws As Worksheet

    ...

    With sh.Rows(ws.Range("B2").Value)
        DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
        .Columns.Count).Value = .Value
    End With

Где ws - это объект рабочего листа, который содержит рассматриваемое значение.Вы не знали, был ли это тот же самый рабочий лист, что и sh, или нет, поэтому, если это так, вы можете изменить ws на sh - в противном случае вам нужно будет Установить wsна лист, который содержит значение.