複製單元格，然後在原始單元格上應用公式

我正在搜索關鍵字，然後將找到的關鍵字中的行內容複製到當前表單中。我然後首先嚐試，以便從細胞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

複製單元格，然後在原始單元格上應用公式

回答

相關問題