Question

我正在尝试粘贴列1，2和＆amp;的值。仅4和列3的公式。

我可以获得或使用所有4列，但我不知道如何只使用.PasteSpecial xlPasteFormulasAndNumberFormats

的1列

Sub FindData() 'Find Both
Application.ScreenUpdating = False
Dim datasheet As Worksheet   'data copied from
Dim reportsheet As Worksheet 'data pasted to
Dim partone As String        'search criteria 1
Dim parttwo As String        'search criteria 2
Dim finalrow As Integer      'find last used row
Dim i As Integer             'row counter

'set variables
Set datasheet = Sheet2
Set reportsheet = Sheet4
partone = reportsheet.Range("E6").Value
parttwo = reportsheet.Range("F6").Value

'clear old data from reort sheet
reportsheet.Range("A10:D110").ClearContents

'goto datasheet and start searching and copying
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row

'loop through the rows to find matching records
For i = 10 To finalrow
If Cells(i, 5) = partone And Cells(i, 6) = parttwo Then
    Range(Cells(i, 1), Cells(i, 4)).Copy
    reportsheet.Select
    Range("A101").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
    datasheet.Select
    End If
Next i

reportsheet.Select
Range("E9:F9").Select
Application.ScreenUpdating = True

End Sub

Answer 1

这仅为我在4列上提供了值。与我的要求相反，但给了我相同的结果。

For i = 10 To finalrow
If Cells(i, 5) = partone And Cells(i, 6) = parttwo Then
    Range(Cells(i, 1), Cells(i, 3)).Copy
    reportsheet.Select
    Range("A101").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
    datasheet.Select
    End If
If Cells(i, 5) = partone And Cells(i, 6) = parttwo Then
    Range(Cells(i, 4), Cells(i, 4)).Copy
    reportsheet.Select
    Range("A101").End(xlUp).Offset(0, 3).PasteSpecial xlPasteValues
    datasheet.Select
    End If
Next i

Answer 2

以下代码仅复制A列中的值：B和D，并将其粘贴到reportsheet，并仅复制C列中的公式。

注意：您有太多Select和非限定对象，下面代码中的对象使用With语句完全符合其工作表。

<强>代码

Option Explicit

Sub FindData() 'Find Both

Dim datasheet As Worksheet   'data copied from
Dim reportsheet As Worksheet 'data pasted to
Dim partone As String        'search criteria 1
Dim parttwo As String        'search criteria 2
Dim finalrow As Long      'find last used row
Dim i As Long             'row counter

Application.ScreenUpdating = False

'set variables
Set datasheet = Sheet2
Set reportsheet = Sheet4

With reportsheet
    partone = .Range("E6").Value
    parttwo = .Range("F6").Value

    'clear old data from reort sheet
    .Range("A10:D110").ClearContents
End With

'  start searching and copying from datasheet
With datasheet
    finalrow = .Cells(.Rows.Count, 1).End(xlUp).Row

    'loop through the rows to find matching records
    For i = 10 To finalrow
        If .Range("E" & i).Value = partone And .Range("F" & i).Value = parttwo Then

            Dim firstEmptyCell As Range
            Set firstEmptyCell = reportsheet.Range("A1000").End(xlUp).Offset(1)

            firstEmptyCell.Resize(1, 2).Value = .Range("A" & i & ":B" & i).Value
            firstEmptyCell.Offset(, 3).Value = .Range("D" & i).Value
            .Range("C" & i).Copy
            firstEmptyCell.Offset(, 2).PasteSpecial xlPasteFormulas
        End If
    Next i
End With

'reportsheet.Select ' <-- not sure why you need it
'Range("E9:F9").Select  ' <-- not sure why you need it
Application.ScreenUpdating = True

End Sub

excel多重粘贴特价

2 个答案: