I want to copy selected columns of a file from a worksheet to a new workbook using VBS in Excel. The following code gives the empty columns in new file.
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
What is wrong with code? Any other method to copy? I followed the answer at Copy from one workbook and paste into another as well. But it also gives blank sheet.
