將數據從一個工作簿複製到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 

代碼有什麼問題？任何其他方法來複制？我也遵循了Copy from one workbook and paste into another的回答。但它也給了白紙。

Answer 1

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

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

是：（？的Excel相同的實例）

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