复制单元格，然后在原始单元格上应用公式
我正在search一个关键字，然后将find的关键字的行内容复制到我当前的工作表中。 然后，我首先尝试将单元格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
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