Question

我正在搜索关键字，然后将找到的关键字中的行内容复制到我当前的工作表中。然后我首先尝试将内容从单元格D复制到单元格Z，然后执行公式：

"=RIGHT(Z2,LEN(Z2)-FIND(""_"",Z2))"

我将代码放在另一个单独的Sub

中

Range("D1:D" & LastRow).Copy Range("Z1:Z" & LastRow) Range("D2:D" & LastRow).Formula = "=RIGHT(Z2,LEN(Z2)-FIND(""_"",Z2))"

如何合并这个公式，以便在Private Sub的每个写入中首先将D单元格复制到单元格Z，然后将公式放在单元格D中？

以下是默认代码：

Sub SearchFolders()
'UpdatebySUPERtoolsforExcel2016
    Dim xFso As Object
    Dim xFld As Object
    Dim xUpdate As Boolean
    Dim xCount As Long
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    xStrSearch = "failed"
    xUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set xOut = wsReport
    xRow = 1
    With xOut
        .Cells(xRow, 1) = "Workbook"
        .Cells(xRow, 2) = "Worksheet"
        .Cells(xRow, 8) = "Unit"
        .Cells(xRow, 9) = "Status"
        Set xFso = CreateObject("Scripting.FileSystemObject")
        Set xFld = xFso.GetFolder(xStrPath)
        xStrFile = Dir(xStrPath & "\*.xlsx")
        Do While xStrFile <> ""
            Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
            For Each xWk In xWb.Worksheets
                Set xFound = xWk.UsedRange.Find(xStrSearch, LookIn:=xlValues)
                If Not xFound Is Nothing Then
                    xStrAddress = xFound.Address
                End If
                Do
                    If xFound Is Nothing Then
                        Exit Do
                    Else

                        xCount = xCount + 1
                        xRow = xRow + 1
                        .Cells(xRow, 1) = xWb.Name
                        .Cells(xRow, 2) = xWk.Name
                        .Cells(xRow, 3) = xFound.Address
                        WriteDetails rCellwsReport, xFound

                    End If
                    Set xFound = xWk.Cells.FindNext(After:=xFound)
                Loop While xStrAddress <> xFound.Address
            Next
            xWb.Close (False)
            xStrFile = Dir
        Loop
        .Columns("A:I").EntireColumn.AutoFit
        .Rows(xCount).EntireRow.AutoFit
    End With

    MsgBox xCount & "cells have been found", , "SUPERtools for Excel"
ExitHandler:
    Set xOut = Nothing


    Application.ScreenUpdating = xUpdate
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Private Sub WriteDetails(ByRef xReceiver As Range, ByRef xDonor As Range)
  xReceiver.Value = xDonor.Parent.Name
  xReceiver.Offset(, 1).Value = xDonor.Address

  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  ' Copy the row of the Donor to the receiver starting from column D.
  ' Since you want to preserve formats, we use the .Copy method
    xDonor.EntireRow.Resize(, 100).Copy xReceiver.Offset(, 2)
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Set xReceiver = xReceiver.Offset(1)

End Sub

Answer 1

xDonor.EntireRow.Resize(, 100).Copy xReceiver.Offset(, 2)

可能需要在上面一行之后添加以下内容：

With xReceiver.Parent.Cells(xReceiver.row, "D")
  .Copy xReceiver.Parent.Cells(xReceiver.row, "Z")
  .Formula = "=RIGHT(Z" & .row & ",LEN(Z" & .row & ")-FIND(""_"",Z" & .row & "))"
End With

复制单元格，然后在原始单元格上应用公式

1 个答案: