Use VBA to paste values from one table to another

问题:

I have the following VBA code that takes a single row from Sheet Tabled data, copies the data, then pastes the data into the next available row in Sheet Running list. However the original row has formulas and I need the values to paste, not the formulas. I've seen numerous ways to do it with Range.PasteSpecial but this code didn't use Range and I'm not sure how to incorporate it.

Note: I modified this code from here: http://msdn.microsoft.com/en-us/library/office/ff837760(v=office.15).aspx. It originally had an If statement to match content in a cell then paste it in a certain sheet according to the content in the cell. I only had one sheet to copy to and didn't need the IF. I don't really need to find the last row of data to copy either as it will only ever be one row with range of A2:N2. But if I take out the FinalRow section and the For and replace with Range("A2:N2"), it doesn't work so I left those in.

Any guidance on how to add in the PasteValues property without making this more complicated I'd really appreciate it! I'm also open to simplification of the For or FinalRow variable such as using Range. I'm only sort of familiar with VBA, having done a few things with it, but usually after much searching and modifying code. Thanks!

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

End Sub

回答1:

Hopefully we can actually make this more simple.

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

edit: I expanded it a little so that there won't be a blank line at the top

回答2:

I found a working solution. I recorded a macro to get the paste special in there and added the extra code to find the next empty row:

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

回答3:

Just copy the data all at once, no need to do it a row at a time.

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

回答4:

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