excel 单元格下移时粘贴的问题

z5btuh9x  于 2023-02-20  发布在  其他
关注(0)|答案(2)|浏览(263)

嗨,我正试图将信息从一个工作簿复制到另一个工作簿,并在单元格下移的同时粘贴。我的问题是根本没有粘贴信息。代码做了所有应该做的事情,除了粘贴行。

Sub filter_copy_paste()

 Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim whatToFind As String
Dim foundTwo As Range
Dim newSelectionRange As Range
Dim rowSelectionRange As Range
Dim Found_Row As Long
Dim num As Integer
'

Sheets("Sheet1").Select

    whatToFind = "Mean"
    
    Set foundTwo = Cells.Find(What:=whatToFind, After:=ActiveCell, LookIn:=xlFormulas2, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
'
Found_Row = foundTwo.row


    With Sheets("Main").Range("A12:S12").CurrentRegion
        .AutoFilter Field:=19, Criteria1:="Yes"
        .SpecialCells(xlCellTypeVisible).EntireRow.Copy
        
        '_
           ' Destination:=Sheets("Sheet1").Range("A1")
'
' I added the following line to insert selection and shift down in Cells above mean
'
             Set rowSelectionRange = Rows(Found_Row - 1).Resize(1)
            rowSelectionRange.Select
             Selection.Insert Shift:=xlDown
    End With
    
'
'Following is added to clean up my previous worksheet
'
    Sheets("Main").Select
        If ActiveSheet.FilterMode = True Then
            ActiveSheet.ShowAllData
        End If
        
    Sheets("Main").Select
    Rows("3:11").Select
    Range("A11").Activate
    Selection.EntireRow.Hidden = True
    Application.CutCopyMode = False
    
    Sheets("Sheet1").Select
    
     Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

我希望复制的行插入到平均值以上的范围内

niknxzdl

niknxzdl1#

这应该可以满足您的需要:

Sub filter_copy_paste()
    
    Const FIND_THIS As String = "mean" 'use const for fixed values
    
    Dim f As Range, numRows As Long, wsSrc As Worksheet, wsDest As Worksheet
   
    Set wsSrc = ThisWorkbook.Worksheets("Main")    'source table
    Set wsDest = ThisWorkbook.Worksheets("Sheet2") 'copy to here
    
    Set f = wsDest.Cells.Find(What:=FIND_THIS, LookIn:=xlFormulas2, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
    If f Is Nothing Then
        MsgBox "'" & FIND_THIS & "' not found on " & wsDest.Name, vbExclamation
        Exit Sub
    End If

    With wsSrc.Range("A12:S12").CurrentRegion
        Debug.Print "Data", .Address()
        .AutoFilter Field:=19, Criteria1:="Yes"
        'how many rows will be copied?
        numRows = .Columns(1).SpecialCells(xlCellTypeVisible).Count
        f.Resize(numRows).EntireRow.Insert shift:=xlDown 'insert the rows
        'copy visible rows
        .SpecialCells(xlCellTypeVisible).Copy wsDest.Cells(f.Row - numRows, "A")
    End With
    
    wsSrc.ShowAllData

End Sub
huwehgph

huwehgph2#

插入过滤的行

Sub InsertFilteredRows()

    Application.ScreenUpdating = False
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Main")
    If sws.FilterMode Then sws.ShowAllData
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    
    Dim srg As Range: Set srg = sws.Range("A12").CurrentRegion
    srg.AutoFilter Field:=19, Criteria1:="Yes"
        Dim svrg As Range: Set svrg = srg.SpecialCells(xlCellTypeVisible)
    sws.AutoFilterMode = False
    
    Dim sarg As Range, srCount As Long
    For Each sarg In svrg.Areas: srCount = srCount + sarg.Rows.Count: Next sarg
    
    'Debug.Print srg.Address, svrg.Address, srCount
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Sheet1")
    If dws.FilterMode Then dws.ShowAllData
    
    Dim durg As Range: Set durg = dws.UsedRange
    Dim dlCell As Range: Set dlCell = durg.Cells(durg.Cells.CountLarge)
    
    ' Starting with the first cell of the used range searching by rows,
    ' attempt to find the first cell that contains the search string.
    ' The search is by default case-insensitive ('A=a').
    Dim dfCell As Range: Set dfCell = dws.Cells.Find( _
        What:="Mean", After:=dlCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows) ' the rest are default parameters
    If dfCell Is Nothing Then Exit Sub ' string not found
    Dim dirg As Range: Set dirg = Intersect(durg, dfCell.EntireRow) _
        .Resize(srCount) ' your code additionally suggests '.Offset(-1)' !?
    
    'Debug.Print svrg.Address, dfCell.Address, dirg.Address
    
    ' Insert and copy.
    
    dirg.Insert Shift:=xlShiftDown
    ' Cannot determine the 'CopyOrigin' parameter without seeing the data.
    
    ' Copy.
    svrg.Copy dirg.Columns(1).Offset(-srCount)
    
    ' Clean up!?
    
    sws.Rows("3:11").Hidden = True
    If Not wb Is ActiveWorkbook Then wb.Activate
    dws.Select
    
    Application.ScreenUpdating = True

    ' Inform.
    
    MsgBox "Filtered rows inserted.", vbInformation

End Sub

相关问题