The last 2 weeks I have immersed myself in VBA. It's great but since last week I have been struggling with the following error: "VBA method 'range of object' _Worksheet failed" with this line of code:
wsSource.Range(Cells(7, ColumnNr), Cells(lrowSource, ColumnNr)).Copy
I can't find the solution.
This is the entire VBA-code:
Sub CopyColums()
Application.ScreenUpdating = False
cPath = "H:\2017\"
ChDrive cPath
ChDir cPath
cFile = Application.GetOpenFilename("Excel files (*.xls*), *.xls*")
Workbooks.Open cFile, UpdateLinks:=3, ReadOnly:=False, Notify:=False, Password:="****"
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lrowSource As Integer
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "import"
Set wsSource = Sheets(1)
Set wsTarget = Sheets("import")
wsTarget.Range("A1").Value = "header 1"
wsTarget.Range("B1").Value = "header 2"
wsTarget.Range("C1").Value = "header 3"
wsTarget.Range("D1").Value = "header 4"
wsTarget.Range("E1").Value = "header 5"
wsTarget.Range("F1").Value = "header 6"
wsTarget.Range("G1").Value = "header 7"
wsTarget.Range("H1").Value = "header 8"
wsTarget.Range("I1").Value = "header 9"
wsTarget.Range("J1").Value = "header 10"
wsTarget.Range("K1").Value = "header 11"
wsTarget.Range("L1").Value = "header 12"
wsTarget.Range("M1").Value = "header 13"
wsTarget.Range("N1").Value = "header 14"
lrowSource = wsSource.Cells(Rows.Count, "A").End(xlUp).Row
'A to A
wsTarget.Range("A2:A" & lrowSource - 5).NumberFormat = "d-m-yy;@"
wsSource.Range("A7:A" & lrowSource).Copy
wsTarget.Range("A2").PasteSpecial xlPasteValues
'E to B
wsSource.Range("E7:E" & lrowSource).Copy
wsTarget.Range("B2").PasteSpecial xlPasteValues
'F to C
wsSource.Range("F7:F" & lrowSource).Copy
wsTarget.Range("C2").PasteSpecial xlPasteValues
'O to D
wsSource.Range("O7:O" & lrowSource).Copy
wsTarget.Range("D2").PasteSpecial xlPasteValues
'Look for column and copy to I
ColumnNr = Application.Match("Total partner", Sheets(1).Rows(6), 0)
wsSource.Range(Cells(7, ColumnNr), Cells(lrowSource, ColumnNr)).Copy
wsTarget.Range("I2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Save as CSV
NameImportFile= Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) 'to remove .xlsx
Filepath = cPath & NameImportFile& ".csv"
ActiveWorkbook.SaveAs Filename:=Filepath, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
End Sub
Can somebody please help me?
Kind regards, Richard
I'm guessing that Sheets(1) isn't active when that line executes.
If that is the case then wsSource is pointing at Sheets(1) while Cells isn't qualifying the sheet it's using, so it's using the currently active sheet.
Try using:
wsSource.Range(wsSource.Cells(7, ColumnNr), wsSource.Cells(lrowSource, ColumnNr)).Copy.
As an edit (after answer accepted) I'd probably rewrite the procedure:
Option Explicit
Public Sub CopyColumns()
Dim cPath As String
Dim cFile As String
Dim wrkBk As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lRowSource As Long
Dim ColumnNr As Long
cFile = GetFile("H:\2017\")
'Continue if a file was selected.
If cFile <> "" Then
Set wrkBk = Workbooks.Open(cFile)
Set wsSource = wrkBk.Worksheets(1)
'Set a reference to worksheet when it's created.
Set wsTarget = wrkBk.Worksheets.Add
With wsTarget
.Name = "Import"
.Move After:=wrkBk.Sheets(wrkBk.Sheets.Count)
'Can use autofill for headers as they're numbered.
wsTarget.Range("A1") = "Header 1"
wsTarget.Range("A1").AutoFill Destination:=Range("A1:N1"), Type:=xlFillDefault
'Could also use
'wsTarget.Range("A1:N1") = array("Header 1", "Header 2", "Header 3", etc....)
End With
'Can use letter or number designation for column in Cells.
lRowSource = wsSource.Cells(Rows.Count, 1).End(xlUp).Row
With wsSource
'This will fail if the lRowSource is 5 or less... lRowSource-5 = 0.
wsTarget.Range(wsTarget.Cells(2, 1), wsTarget.Cells(lRowSource - 5, 1)).NumberFormat = "d-m-yy;@"
ColumnNr = Application.Match("Total partner", wsSource.Rows(6), 0)
'Use UNION to copy columns A,E:F,O & ColumnNr
Union(.Range(.Cells(7, 1), .Cells(lRowSource, 1)), _
.Range(.Cells(7, 5), .Cells(lRowSource, 6)), _
.Range(.Cells(7, 15), .Cells(lRowSource, 15)), _
.Range(.Cells(7, ColumnNr), .Cells(lRowSource, ColumnNr))).Copy
wsTarget.Cells(2, 1).PasteSpecial xlPasteValues
End With
wsTarget.Copy
With wrkBk
'Save with workbook name as CSV.
ActiveWorkbook.SaveAs .Path & Application.PathSeparator & _
Left(wrkBk.Name, InStrRev(wrkBk.Name, ".")) & "csv", 6
'Save with worksheet name as CSV.
'ActiveWorkbook.SaveAs .Path & Application.PathSeparator & _
wsTarget.Name & ".csv", 6
End With
End If
End Sub
Function GetFile(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select a File"
.AllowMultiSelect = False
.Filters.Add "File to copy columns from", "*.xls*", 1
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function