Run time error 9 subcript out of range and invoice automation - vba

I am trying to run some VBA code to generate an automated invoice, but I am receiving the following error:
Error 9 subscript out of range
for this code.
lastrow = Sheets(“CustomerDetails”).Range(“A” & Rows.Count).End(xlUp).Row
Any idea what could be causing this?
Private Sub CommandButton1_Click()
Dim customername As String
Dim customeraddress As String
Dim invoicenumber As Long
Dim r As Long
Dim mydate As String
Dim path As String
Dim myfilename As String
lastrow = Sheets(“CustomerDetails”).Range(“A” & Rows.Count).End(xlUp).Row
r = 2
For r = 2 To lastrow
If Cells(r, 17).Value = “done” Then GoTo nextrow
customername = Sheets(“CustomerDetails”).Cells(r, 1).Value
customeraddress = Sheets(“CustomerDetails”).Cells(r, 2).Value
invoicenumber = Sheets(“CustomerDetails”).Cells(r, 6).Value
quantity = Sheets(“CustomerDetails”).Cells(r, 18).Value
Description = Sheets(“CustomerDetails”).Cells(r, 19).Value
UnitPrice = Sheets(“CustomerDetails”).Cells(r, 20).Value
SalesTaxRate = Sheets(“CustomerDetails”).Cells(r, 16).Value
Cells(r, 17).Value = “done”
Application.DisplayAlerts = False
Workbooks.Open (“C \ invoices \ BasicInvoice.xlsx”)
ActiveWorkbook.Sheets(“BasicInvoice”).Activate
ActiveWorkbook.Sheets(“BasicInvoice”).Range(“I8”).Value = invoicenumber
ActiveWorkbook.Sheets(“BasicInvoice”).Range(“C8”).Value = customername
ActiveWorkbook.Sheets(“BasicInvoice”).Range(“C9”).Value = customeraddress
ActiveWorkbook.Sheets(“BasicInvoice”).Range(“B21”).Value = quantity
ActiveWorkbook.Sheets(“BasicInvoice”).Range(“C21”).Value = Description
ActiveWorkbook.Sheets(“BasicInvoice”).Range(“H21”).Value = UnitPrice
ActiveWorkbook.Sheets(“BasicInvoice”).Range(“D18”).Value = SalesTaxRate
path = “C \ invoices \ ”
mydate = Date
mydate = Format(mydate, “mm_dd_yyyy”)
ActiveWorkbook.SaveAs Filename:=path & invoicenumber & “ - ” & customername
& “ - ” & mydate & “.xlsx”
myfilename = ActiveWorkbook.FullName
SetAttr myfilename, vbReadOnly
Application.DisplayAlerts = True
'ActiveWorkbook.PrintOut copies:=1
ActiveWorkbook.Close SaveChanges:=False
nextrow:
Next r
End Sub

This is the function I have saved in my personal macro workbook:
Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
With ws
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
It is something that I use daily which is why it's there, and you might want to do the same if it's causing you problems
so get rid of that line completely, copy the above code to your module, then whatever you were using lastrow for, update it to include the worksheet.
You would call this function like this (assuming that you don't have a declaration for your workbook):
... = LastRow(Worksheets("CustomerDetails"))
Edit: I had to completely rewrite your code, so please make sure everything works
Code:
Option Explicit
Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
With ws
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
Private Sub CommandButton1_Click()
Const path$ = "C:\invoices\"
Dim customername As String, customeraddress As String, invoicenumber As Long
Dim r As Long, mydate As String, myfilename As String, wbInv As Workbook
Dim quantity, Description, UnitPrice, SalesTaxRate
Dim tempWB As Workbook
Dim wsCD As Worksheet
Set wsCD = ThisWorkbook.Worksheets("CustomerDetails")
For r = 2 To LastRow(wsCD)
If Not Cells(r, 17).Value = "done" Then
With wsCD
customername = .Cells(r, 1).Value
customeraddress = .Cells(r, 2).Value
invoicenumber = .Cells(r, 6).Value
quantity = .Cells(r, 18).Value
Description = .Cells(r, 19).Value
UnitPrice = .Cells(r, 20).Value
SalesTaxRate = .Cells(r, 16).Value
.Cells(r, 17).Value = "done"
End With
Application.DisplayAlerts = False
Set wbInv = Workbooks.Open("C:\invoices\BasicInvoice.xlsx")
With wbInv.Worksheets("BasicInvoice")
.Range("I8").Value = invoicenumber
.Range("C8").Value = customername
.Range("C9").Value = customeraddress
.Range("B21").Value = quantity
.Range("C21").Value = Description
.Range("H21").Value = UnitPrice
.Range("D18").Value = SalesTaxRate
End With
mydate = Format(Date, "mm_dd_yyyy")
wbInv.SaveAs Filename:=path & invoicenumber & " - " & customername & _
" - " & mydate & ".xlsx"
myfilename = ActiveWorkbook.FullName
SetAttr myfilename, vbReadOnly
Application.DisplayAlerts = True
'ActiveWorkbook.PrintOut copies:=1
wbInv.Close SaveChanges:=False
Set wbInv = Nothing
Set tempWB = Nothing
End If
Next r
End Sub

Related

Excel VBA DoWhile Loop - how to return list of items with each loop?

I am pulling entries from a purchase order template in 1 worksheet into a database worksheet that will record all purchase order date in the same Excel workbook. The SKU's ordered on the order template tab will often exceed 1, and will differ from one another. Wondering how to pull the differing SKU No.'s into the database tab with an edit to VBA code below:
Private Sub CommandButton1_Click()
Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String
Worksheets("Order Form 1").Select
OrderDate = Range("B3")
PONumber = Range("D3")
Vendor = Range("B7")
ShipTo = Range("D7")
SKU = Range("F3")
R = 3
Do While Cells(R, 6) <> ""
Worksheets("Database").Select
Worksheets("Database").Range("A1").Select
If Worksheets("Database").Range("A1").Offset(1, 0) <> "" Then
Worksheets("Database").Range("A1").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = OrderDate
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = PONumber
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Vendor
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ShipTo
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = SKU
Worksheets("Order Form 1").Select
R = R + 1
Loop
End Sub
I agree that all of the .Selects and ActiveCell references are ugly. But, in trying to leave as much of your code alone as possible, here is one method:
Private Sub CommandButton1_Click()
Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String
Dim R As Long, LastRow As Long
Worksheets("Order Form 1").Select
OrderDate = Range("B3")
PONumber = Range("D3")
Vendor = Range("B7")
ShipTo = Range("D7")
LastRow = Worksheets("Order Form 1").Cells(Worksheets("Order Form 1").Rows.Count, "F").End(xlUp).Row
For R = 3 To LastRow
SKU = Range("F" & R).Value
Worksheets("Database").Select
Worksheets("Database").Range("A1").Select
If Worksheets("Database").Range("A1").Offset(1, 0) <> "" Then
Worksheets("Database").Range("A1").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = OrderDate
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = PONumber
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Vendor
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ShipTo
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = SKU
Worksheets("Order Form 1").Select
Next R
End Sub
And here is an effort to eliminate .Selects and ActiveCell references:
Private Sub CommandButton1_Click()
Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
Set OFrm = Worksheets("Order Form 1")
Set DB = Worksheets("Database")
OrderDate = OFrm.Range("B3")
PONumber = OFrm.Range("D3")
Vendor = OFrm.Range("B7")
ShipTo = OFrm.Range("D7")
LastSKURow = OFrm.Cells(OFrm.Rows.Count, "F").End(xlUp).Row
For R = 3 To LastSKURow
SKU = OFrm.Range("F" & R).Value
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Value = OrderDate
DB.Range("B" & NextDBRow).Value = PONumber
DB.Range("C" & NextDBRow).Value = Vendor
DB.Range("D" & NextDBRow).Value = ShipTo
DB.Range("E" & NextDBRow).Value = SKU
Next R
End Sub

My code is supposed to move to a new line and add new customer to the database,its showing error

Private Sub cmdSave_Click()
Dim CustomerNumber As String, FullName As String, ContactNumber As Long, CompanyName As String
Worksheets("CustForm").Select
CustomerNumber = Range("D4")
FullName = Range("D5")
ContactNumber = Range("D6")
CompanyName = Range("D7")
Worksheets("CustomerList").Select
Worksheets("CustomerList").Range("A5").Select
If Worksheets("CustomerList").Range("A5").Offset(1, 0) <> "" Then
**Worksheets("CustomerList").Range("A5").End(x1Down).Select**
(here is where my error points me too)
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = CustomerNumber
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = FullName
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = CompanyName
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = ContactNumber
Worksheets("CustForm").Select
Worksheets("CustForm").Visible = True
Worksheets("OrderInvoice").Activate
Range("D4:J7").Select
Selection.ClearContents
End Sub
There are a number of ways to improve upon your code. I've rewritten the functionality below and avoided the use of .Select and .Activate as it's not recommended to use these.
Private Sub cmdSave_Click()
Dim CustomerNumber As String, FullName As String, ContactNumber As Long, CompanyName As String
Dim wsForm As Worksheet: Set wsForm = ThisWorkbook.Worksheets("CustForm")
Dim wsList As Worksheet: Set wsList = ThisWorkbook.Worksheets("CustomerList")
Dim firstEmptyRow As Long
With wsList
firstEmptyRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & firstEmptyRow) = wsForm.Range("D4")
.Range("B" & firstEmptyRow) = wsForm.Range("D5")
.Range("C" & firstEmptyRow) = wsForm.Range("D7")
.Range("D" & firstEmptyRow) = wsForm.Range("D6")
End With
Worksheets("OrderInvoice").Range("D4:J7").ClearContents
End Sub
This code should do exactly the same as you have in your original function, but as you can see it's a lot shorter, neater and tidier. Let me know if there is any aspect of the code above you don't understand and I'll explain it if you need it.

Generate new worksheet based on column data for LARGE spreadsheets

I have a spreadsheet with 800k rows and 150 columns. I'm attempting to create new worksheets based on the contents of a column. So, for example if column Y has many elements ("alpha", "beta", "gamma", etc.) then I'd like to create new worksheets named "alpha", "beta", "gamma" which contain only the rows from the original that have those respective letters. I've found two scripts that work for smaller spreadsheets, but due to the size of this particular spreadsheet, they don't work.
Here are the two scripts that I have tried:
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
this returns "overflow"
the other code that I have tried:
Sub columntosheets()
Const sname As String = "VOTERFILE_WITHABSENTEEINFORMATI" 'change to whatever starting sheet
Const s As String = "O" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
End Sub
Returns error with "excel does not have enough resources".
Is it possible to do what I want on my hardware?
You can refer to the modified subroutine in another article 'Macro for copying and pasting data to another worksheet'.
Sub CopySheet()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on
LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
' column G has the criteria eg project ref
wsAll.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit
wsAll.Copy Before:=Sheets("All")
ActiveSheet.Name = wsCrit.Range("A2")
Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=wsCrit.Range("A1:A2"), _
Unique:=False
wsCrit.Rows(2).Delete
Next I
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
End Sub

Generate Multiple excel file from multiple line in excel

I am trying to generate multiple Excel file from a list in excel. Below are the code i tried but got runtime error 70.
The excel i use are (which can be download here: https://drive.google.com/folderview?id=0B7u1K6cUEOzeWURZWWd3NjQ4R0k&usp=sharing)
1) BasicInvoice.xlsx
2) 2011.xlsx
Private Sub CommandButton1_Click()
Dim Name As String
Dim invoicenumber As Long
Dim r As Long
Dim path As String
Dim myfilename As String
lastrow = Sheets("1").Range("A" & Rows.Count).End(xlUp).Row
r = 2
For r = 2 To lastrow
Date = Sheets("1").Cells(r, 1).Value
invoicenumber = Sheets("1").Cells(r, 2).Value
Name = Sheets("1").Cells(r, 3).Value
Description = Sheets("1").Cells(r, 4).Value
Amount = Sheets("1").Cells(r, 5).Value
Workbooks.Open ("BasicInvoice.xlsx")
ActiveWorkbook.Sheets("BasicInvoice").Activate
ActiveWorkbook.Sheets("BasicInvoice").Range("E9").Value = Date
ActiveWorkbook.Sheets("BasicInvoice").Range("E10").Value = invoicenumber
ActiveWorkbook.Sheets("BasicInvoice").Range("B9").Value = Name
ActiveWorkbook.Sheets("BasicInvoice").Range("B16").Value = Description
ActiveWorkbook.Sheets("BasicInvoice").Range("E16").Value = Amount
path = "C:\invoices\"
ActiveWorkbook.SaveCopyAs Filename:=path & invoicenumber & ".xlsx"
myfilename = ActiveWorkbook.FullName
Application.DisplayAlerts = True
ActiveWorkbook.PrintOut copies:=1
ActiveWorkbook.Close SaveChanges:=False
nextrow:
Next r
End Sub
RunTime Error 70 indicates that you're unable to write to something write protected. What line are you getting the error on?
Check to make sure that C:/Invoices folder actually exists on your hard drive.
Below is a tidy up of your code while I'm here.
Private Sub CommandButton1_Click()
Dim wbInv As Workbook, wsInv As Worksheet
Dim wbSrc As Workbook, wsSrc As Worksheet
Dim lastrow As Long, r As Long
Dim path As String
Set wbSrc = ThisWorkbook
Set wsSrc = wbSrc.Sheets("1")
Set wbInv = Workbooks.Open("BasicInvoice.xlsx")
Set wsInv = wbInv.Sheets("BasicInvoice")
path = "C:\invoices\"
lastrow = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For r = 2 To lastrow
With wsInv
.Range("E9").Value = wsSrc.Cells(r, 1).Value
.Range("E10").Value = wsSrc.Cells(r, 2).Value
.Range("B9").Value = wsSrc.Cells(r, 3).Value
.Range("B16").Value = wsSrc.Cells(r, 4).Value
.Range("E16").Value = wsSrc.Cells(r, 6).Value
End With
With wbInv
.SaveCopyAs Filename:=path & wsInv.Range("E10").Value & ".xlsx"
.PrintOut copies:=1
End With
Next r
wbInv.Close SaveChanges = False
Application.ScreenUpdating = True
End Sub

Copy range to another sheet and insert name from Input Box with this copy

I have User form where I have command button and input text box.
I want to copy specified range from one worksheet, then name and paste in another sheet.
My code looks like this, but it is not working.
Private Sub CommandButton1_Click()
Dim i, LastRow
Dim ws As Worksheet
Dim k As Integer
Set ws = Worksheets("Vali")
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To LastRow 'find fulfiled rows
If Sheets("Sheet1").Cells(i, "D").Value = 1 Then
Sheets("Sheet1").Range(Cells(i, "B"), Cells(i, "D")).Copy Destination:=Sheets("Vali").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
Dim i As Integer
'Next we use a looping process 'We start the loop from row 2 because our worksheet has headers in row 1
For k = 2 To 100
'Now we define a condition that only if there is data under the headers ItemID, Description,
If Cells(k, "A").Value <> "" And Cells(k, "B").Value <> "" And Cells(k, "C").Value <> "" And Cells(k, "D").Value <> "" And Cells(k, "E").Value = "" Then
Cells(k, "D").Value = Me.txtname.Value
End If
Next
Range("E:E").EntireColumn.AutoFit
Range("B4:D21").ClearContents 'clear content on previos sheet, from where we made copy
ActiveWorkbook.Save
ValiFinish.Hide
End Sub
Not sure what you were trying to do with your test on you second loop, because there was no sheet reference, so I choose, let me know if it wasn't that
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim LastRow As Double
Dim ws As Worksheet
Dim Wv As Worksheet
Dim k As Integer
Dim i As Integer
Dim Ti()
ReDim Ti(0)
Dim StartPaste As Double
Dim EndPaste As Double
Dim PastedRange As String
Set ws = Worksheets("Sheet1")
Set Wv = Worksheets("Vali")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
StartPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
For i = 2 To LastRow
If ws.Cells(i, "D").Value = 1 Then
ws.Range(ws.Cells(i, "A"), ws.Cells(i, "D")).Copy _
Destination:=Wv.Range("A" & Rows.Count).End(xlUp).Offset(1)
Ti(UBound(Ti)) = i
ReDim Preserve Ti(UBound(Ti) + i)
EndPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
'2 options because i'm not sur where you want to add the text :
'First one (write on Vali, I think that's what you are looking to do) :
If Wv.Cells(EndPaste, "A").Value <> "" And Wv.Cells(EndPaste, "B").Value <> "" And Wv.Cells(EndPaste, "C").Value <> "" _
And Wv.Cells(EndPaste, "D").Value <> "" And Wv.Cells(EndPaste, "E").Value = "" Then
Wv.Cells(Wv.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value
End If
'Second one (write on Sheet1) :
If ws.Cells(i, "A").Value <> "" And ws.Cells(i, "B").Value <> "" And ws.Cells(i, "C").Value <> "" _
And ws.Cells(i, "D").Value <> "" And ws.Cells(i, "E").Value = "" Then
ws.Cells(ws.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value
End If
'end of options
End If
Next i
PastedRange = "" & Wv.Name & "!R" & StartPaste & "C1:R" & EndPaste & "C3"
ActiveWorkbook.Names.Add Name:=ValiFinish.TxTNaMe.Value, RefersToR1C1:=PastedRange
'clear content on previous sheet, from where we made copy
For i = LBound(Ti) To UBound(Ti) - 1
ws.Range("$B$" & Ti(i) & ":$D$" & Ti(i)).ClearContents
Next i
Wv.Range("E:E").EntireColumn.AutoFit
Set ws = Nothing
Set Wv = Nothing
ActiveWorkbook.Save
ValiFinish.Hide
Application.ScreenUpdating = True
End Sub