使用VBA将值从一个表粘贴到另一个表

Posted 2021-03-26

我有以下VBA代码，从Sheet Tabled数据中获取单行，复制数据，然后将数据粘贴到Sheet Running列表中的下一个可用行。但是原始行有公式，我需要粘贴值，而不是公式。我已经看到使用Range.PasteSpecial做了很多方法，但是这段代码没有使用Range，我不知道如何合并它。

注意：我从这里修改了这段代码：http://msdn.microsoft.com/en-us/library/office/ff837760(v=office.15).aspx。它最初有一个If语句来匹配单元格中的内容，然后根据单元格中的内容将其粘贴到某个表单中。我只有一张要复制的表，不需要IF。我真的不需要找到要复制的最后一行数据，因为它只会是一行，范围为A2：N2。但是如果我取出FinalRow部分和For并用Range替换（“A2：N2”），它就不起作用所以我把它们留在了。

任何有关如何添加PasteValues属性而不会使其更复杂的指导我真的很感激！我也愿意简化For或FinalRow变量，例如使用Range。我只是熟悉VBA，用它做了一些事情，但通常经过多次搜索和修改代码。谢谢！

Public Sub CopyData()
Sheets("Tabled data").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
 ' Loop through each row
For x = 2 To FinalRow
    ThisValue = Cells(x, 1).Value
    Cells(x, 1).Resize(1, 14).Copy
    Sheets("Running list").Select
    NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Cells(NextRow, 1).Select
    ActiveSheet.Paste
    Sheets("Tabled data").Select
Next x

结束子

答案

希望我们能够让这更简单。

Public Sub CopyRows()
    Sheets("Sheet1").UsedRange.Copy
    lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    'check if the last cell found is empty
    If IsEmpty(ActiveSheet.Cells(lastrow, 1)) = True Then
        'if it is empty, then we should fill it
        nextrow = lastrow
    Else
        'if it is not empty, then we should not overwrite it
        nextrow = lastrow + 1
    End If

    ActiveSheet.Cells(nextrow, 1).Select
    ActiveSheet.Paste
End Sub

编辑：我扩展了一点，以便顶部不会有空行

另一答案

我找到了一个有效的解决方我录制了一个宏来获取特殊的粘贴，并添加了额外的代码来查找下一个空行：

Sub Save_Results()
' Save_Results Macro
  Sheets("Summary").Select 'renamed sheets for clarification, this was 'Tabled data'
'copy the row  
  Range("Table1[Dataset Name]").Select
  Range(Selection, Selection.End(xlToRight)).Select
  Selection.Copy
' paste values into the next empty row
  Sheets("Assessment Results").Select
  Range("A2").Select
  NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
  Cells(NextRow, 1).Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
' Return to main sheet      
Sheets("Data Assessment Tool").Select
End Sub

另一答案

只需一次复制数据，无需一次连续执行。

Sub CopyData()

    With ThisWorkbook.Sheets("Tabled data")
        Dim sourceRange As Range
        Set sourceRange = .Range(.Cells(2, 1), .Cells(getLastRow(.Range("A1").Parent), 14))
    End With

    With ThisWorkbook.Sheets("Running list")
        Dim pasteRow As Long
        Dim pasteRange As Range
        pasteRow = getLastRow(.Range("A1").Parent) + 1
        Set pasteRange = .Range(.Cells(pasteRow, 1), .Cells(pasteRow + sourceRange.Rows.Count, 14))
    End With

    pasteRange.Value = sourceRange.Value

End Sub
Function getLastRow(ws As Worksheet, Optional colNum As Long = 1) As Long

    getLastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row

End Function

另一答案

Private Sub Load_Click()

    Call ImportInfo

End Sub

Sub ImportInfo()

    Dim FileName As String
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim ActiveListWB As Workbook
    Dim check As Integer

    'Application.ScreenUpdating = False
    Set WS2 = ActiveWorkbook.Sheets("KE_RAW")
        confirm = MsgBox("Select (.xlsx) Excel file for Data transfer." & vbNewLine & "Please ensure the sheets are named Sort List, Second and Third.", vbOKCancel)

    If confirm = 1 Then
        FileName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xls*", _
                Title:="Select Active List to Import", MultiSelect:=False)

        If FileName = "False" Then
                MsgBox "Import procedure was canceled"
                Exit Sub
            Else
                Call CleanRaw
                Set ActiveListWB = Workbooks.Open(FileName)
        End If

        Set WS1 = ActiveListWB.Sheets("Sort List")
        WS1.UsedRange.Copy 'WS2.Range("A1")
       ' WS2.Range("A1").Select
        WS2.UsedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        'WS2.Range ("A1")
        ActiveWorkbook.Close False

     'Call ClearFormulas

       ' Call RefreshAllPivotTables

        Sheets("Key Entry Data").Select
        'Sheets("Raw").Visible = False
        'Application.ScreenUpdating = True
        MsgBox "Data has been imported to workbook"

    Else
        MsgBox "Import procedure was canceled"
    End If

        Application.ScreenUpdating = True

End Sub

Sub CleanRaw()

    Sheets("KE_RAW").Visible = True
    Sheets("KE_RAW").Activate
    ActiveSheet.Cells.Select
    Selection.ClearContents

End Sub