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)

由：

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

将数据从一个工作簿复制到excel VBA中的新工作簿

1 个答案: