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

我正在搜索关键字，然后将找到的关键字中的行内容复制到当前表单中。我然后首先尝试，以便从细胞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

来源

2017-07-07 Joe

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

来源

2017-07-07 18:26:49

感谢您的解决方案，我想在D单元格中输入公式'“= RIGHT（Z2，LEN（Z2）-FIND（”“_”“，Z2））”'...我做了以下操作：... .Formula =“= RIGHT （Z2，LEN（Z2） - 查找（ “” _ “”，Z2））“'但是当公式不会随着单元格向下移动而变化，即在第46行上，公式应该变成：“.Formula =”= RIGHT（Z46，LEN（Z46）-FIND（“”_“”，Z46））“ '。你能告诉我如何得到这个输出吗？谢谢！ – Joe

@Joe在代码中查看修改后的公式。 –

这有效......谢谢！ – Joe

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

回答

相关问题