在excel VB中將數據從一個工作簿復制到新工作簿

Question

我想使用 Excel 中的 VBS 將文件的選定列從工作表復制到新工作簿。 以下代碼給出了新文件中的空列。

 Option Explicit
 'Function to check if worksheets entered in input boxes exist
 Public Function wsExists(ByVal WorksheetName As String) As Boolean

    On Error Resume Next
    wsExists = (Sheets(WorksheetName).Name <> "")
    On Error GoTo 0 ' now it will error on further errors

 End Function

 Sub createEndUserWB()

    Dim i As Integer
    Dim colFound As String
    Dim b(1 To 1) As Integer
    Dim Sheet_Copy_From As String
    Dim newSheet As String
    Dim colVal As Variant 'sheet name from array to test
    Dim colNames As Variant 'Array
    Dim col As Variant
    Dim colN As Integer
    Dim lkr As Range
    Dim destWS As Worksheet
    Dim endUserWB As Workbook
    Dim lastRow As Integer



    'Application.ScreenUpdating = False 'Speeds up the routine by not updating the screen.
    'IMPORTANT, remember to turn screen updating back on before the routine ends


    '***** ENTERING WORKSHEET NAMES *****

    'Get the name of the worksheet to be copied from
    Sheet_Copy_From = Application.InputBox(Prompt:= _
            "Please enter the sheet name you which to copy from", _
            Title:="Sheet_Copy_From", Type:=2) 'Type:=2 = text
    If Sheet_Copy_From = "False" Then 'If Cancel is clicked on Input Box exit sub
        Exit Sub
    End If

    '*****CHECK TO SEE IF WORKSHEETS EXIST (USES FUNCTION AT VERY TOP)*****
    Select Case wsExists(Sheet_Copy_From) 'calling function at very top
        Case False
            MsgBox "The worksheet named """ & Sheet_Copy_From & """ is either missing" & vbNewLine & _
                "or spelt incorrectly" & vbNewLine & vbNewLine & _
                "Please rectify and then run this procedure again" & vbNewLine & vbNewLine & _
                "Select OK to exit", _
                vbInformation, ""
             Exit Sub
     End Select

     Set destWS = ActiveWorkbook.Sheets(Sheet_Copy_From)


    'array of sheet names to test for
     colNames = Array("SID", "First Name", "Last Name", "xyz", "Telephone Number", "Department")

    'Get the name of the worksheet to pasted into
     newSheet = Application.InputBox(Prompt:= _
            "Please enter the sheet name you which to paste in", _
            Title:="New File", Type:=2) 'Type:=2 = text
     If newSheet = "False" Then 'If Cancel is clicked on Input Box exit sub
         Exit Sub
     End If

     Set endUserWB = Workbooks.Add
     endUserWB.SaveAs Filename:=newSheet
     endUserWB.Sheets(1).Name = "Sheet1"
     'endUserWS.Name = "End User"

    'Copy Columns 1 by 1
    i = 1
    For Each col In colNames
        On Error GoTo colNotFound
        colN = destWS.Rows(1).Find(col, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Column
        lastRow = destWS.Cells(Rows.Count, colN).End(xlUp).Row
        'MsgBox "Column for " & colN & " is " & lastRow, vbInformation, ""


        'Copy paste Part begins here
        If colN <> -1 Then
            'destWS.Select
            'colVal = destWS.Columns(colN).Select
            'Selection.Copy
            'endUserWB.ActiveSheet.Columns(i).Select
            'endUserWB.ActiveSheet.PasteSpecial Paste:=xlPasteValues
            'endUserWB.Sheets(1).Range(Cells(2, i), Cells(lastRow, i)).Value = destWS.Range(Cells(2, colN), Cells(lastRow, colN))
            destWS.Range(2, lastRow).Copy
            endUserWB.Worksheets("Sheet1").Range(2).PasteSpecial (xlPasteValues)
        End If
        i = i + 1
    Next col
    Application.CutCopyMode = False 'Clears the clipboard
        'MsgBox "Column """ & colN & """ is Found",vbInformation , ""

    colNotFound:
        colN = -1
        Resume Next
 End Sub

代碼有什么問題？ 還有什么方法可以復制嗎？ 我按照從一本工作簿復制並粘貼到另一本工作簿中的答案進行操作。 但它也給出了白紙。

Answer 1

如果我理解正確，請嘗試更改代碼的這一部分：

destWS.Range(2, lastRow).Copy
endUserWB.Worksheets("Sheet1").Range(2).PasteSpecial (xlPasteValues)

經過：

destWS.Activate
destWS.Range(Cells(2, colN), Cells(lastRow, colN)).Copy
endUserWB.Activate
endUserWB.Worksheets("Sheet1").Cells(2, colN).PasteSpecial (xlPasteValues)