В вашем коде отсутствуют объявления. Учитывая множество переменных, которые нужны вашему дизайну, я решил, что наилучшим способом было бы объявить Types. Это пользовательские структурированные переменные, в основном массивы с именованными элементами. Поскольку теперь вы хотите записывать заголовки и тела счетов в отдельных операциях (много элементов тела для каждого заголовка), вам нужны разные типы для тела счета и элементов счета.
Type Invoice
ClientName As String
Address As String
PiNo As String
PiDate As Date
Salesperson As String
PoNo As String
VAT As Double
PaymentTerms As String
PaymentMode As String
ShipDate As Date
DispatchThrough As String
End Type
Type Item
Qty As Double
PartNo As String
Description As String
UnitPrice As Double
End Type
Private Sub CommandButton1_Click()
Const InvoiceItemRow As Long = 25 ' modify to suit
Dim WbInv As Workbook
Dim Path As String
Dim InvFileName As String
Dim WsInv As Worksheet
Dim WsCust As Worksheet ' always name your sheet
Dim PiNo As String, Pi As String
Dim Inv As Invoice, Itm As Item
Dim Pos As Integer ' invoice item counter (1st item = 0)
Dim NewInvoice As Boolean
Dim LastRow As Long
Dim R As Long
Path = "C:\Users\admin\Desktop\Invoices\"
' you may like to use this syntax instead
Path = Environ("UserProfile") & "\Desktop\Invoices\"
' Spaces are permitted in tab names. You may use "Customer Details"
Set WsCust = ThisWorkbook.Worksheets("CustomerDetails")
' observe the leading period in .Rows.Count. That's why to use the With statement.
With WsCust
' Use the Range object to define a range
LastRow = .Range("H" & .Rows.Count).End(xlUp).Row
' but use the Cells collection to define a cell.
LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row
' delete the line you don't want to keep
End With
Application.ScreenUpdating = False ' avoid flicker
For R = 2 To LastRow
Pi = WsCust.Cells(R, 5).Value
If PiNo <> Pi Then
NewInvoice = True
If Not WbInv Is Nothing Then
' if there is a started invoice already, close it
InvFileName = Path & Inv.PiNo & ".xlsx"
With WbInv
.SaveAs Filename:=InvFileName, FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=True
End With
End If
Inv = SetInvoice(R, WsCust)
End If
Itm = SetItem(R, WsCust)
If NewInvoice Then
' if it's a template, save it with xltx or xltm extension
' and, in any case, create a copy with the Add Method
Set WbInv = Workbooks.Add("C:\Users\admin\Desktop\InvoiceTemplate.xlsx")
Set WsInv = WbInv.Worksheets("InvoiceTemplate")
With WsInv
.Cells(16, "B").Value = .ClientName
.Cells(17, "B").Value = Inv.Address
.Cells(8, "AG").Value = Inv.PiNo
.Cells(8, "Z").Value = Inv.PiDate
.Cells(21, "T").Value = Inv.Salesperson
.Cells(8, "AN").Value = Inv.PoNo
.Cells(39, "AL").Value = Inv.VAT
.Cells(21, "K").Value = Inv.PaymentTerms
.Cells(21, "AL").Value = Inv.PaymentMode
.Cells(21, "B").Value = Inv.ShipDate
.Cells(21, "AC").Value = Inv.DispatchThrough
End With
Pos = 0 ' reset item counter
NewInvoice = False
Else
Pos = Pos + 1
End If
With WsInv.Rows(InvoiceItemRow + Pos)
' find out the column number with Debug.Print ? Columns("AF").Column
.Cells(2).Value = PartNo
.Cells(10).Value = Description
.Cells(25).Value = Qty
.Cells(32).Value = UnitPrice
End With
PiNo = Pi
Next R
Application.ScreenUpdating = True
End Sub
Private Function SetInvoice(ByVal R As Long, _
Ws As Worksheet) As Invoice
Dim Fun As Invoice
With Fun
.ClientName = Ws.Cells(R, 6).Value
.Address = Ws.Cells(R, 13).Value
.PiNo = Ws.Cells(R, 5).Value
.PiDate = Ws.Cells(R, 4).Value
.Salesperson = Ws.Cells(R, 1).Value
.PoNo = Ws.Cells(R, 3).Value
.VAT = Ws.Cells(R, 17).Value
.PaymentTerms = Ws.Cells(R, 7).Value
.PaymentMode = Ws.Cells(R, 16).Value
.DispatchThrough = Ws.Cells(R, 15).Value
.ShipDate = Ws.Cells(R, 14).Value
End With
End Function
Private Function SetItem(ByVal R As Long, _
Ws As Worksheet) As Item
Dim Fun As Item
With Fun
.Qty = Ws.Cells(R, 9).Value
.PartNo = Ws.Cells(R, 8).Value
.Description = Ws.Cells(R, 12).Value
.UnitPrice = Ws.Cells(R, 10).Value
End With
SetItem = Fun
End Function
Я тестировал этот код небрежно за исключением части «Сохранить и закрыть». Если ваше более тщательное тестирование выявит ошибки, просим вас сообщить мне об этом, и я их исправлю.
Проверка процедуры SaveAs ============= (Изменить 7 апреля , 2020)
Процедура ниже является выдержкой из вышеперечисленного. Он использует тот же синтаксис для SaveAs, что и приведенный выше код. Выполните следующие действия.
- Создайте новую книгу из вашего InvoiceTemplate. Его имя должно быть
InvoiceTemplate1 и никогда не сохраняться раньше. Сделайте это ActiveWorkbook. - Измените процедуру, чтобы создать переменную
InvFilename точно так же, как это делает ваш код. Затем запустите процедуру.
Private Sub TestSaveAs ()
Dim WbInv As Workbook
Dim InvFilename As String
Set WbInv = ActiveWorkbook
InvFilename = Environ("UserProfile") & "\Desktop\MyWorkbook.xlsx"
With WbInv
.SaveAs Filename:=InvFilename, FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=True
End With
End Sub