sunt autodidact dar se pare ca nu inteleg excel cum as dori eu , am un fisier pentru factura dar am mai creat cateva taburi pentru:Customers, Invoice, chitanta, Chitanta diferenta, voucher Registru facturi, Baza de date clienti, valuta.
Sa va explic momentan completez in tab Customers campurile si populeaza automat factura si chitantele si salveaza o copie dupa factura...
am incercat sa fac in asa fel sa creeze o copie si dupa taburile chitanta si diferenta chitanta dar nu am reusit, de asemenea nu stiu de ce nu functioneaza sa fac o baza de date dupa clienti la fel ca registru facturi... imi da o erroare (am copiat codul de la registru facturi si am modificat dar ...nu merge ..acum sters codul pt a nu avea errori).
mai jos gasiti codul si un link cu fisierul excel daca ma puteti ajuta as aprecia foarte mult.
http://www.sctr.ro/artemis-macro2.xlsm
Cu respect
Adrian
Cod: Selectaţi tot
Sub PostToRegister()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim WS4 As Worksheet
Dim WS5 As Worksheet
Dim WS6 As Worksheet
Dim WS7 As Worksheet
Set WS1 = Worksheets("Invoice")
Set WS2 = Worksheets("Registru Facturi")
Set WS3 = Worksheets("Customers")
Set WS4 = Worksheets("chitanta")
Set WS5 = Worksheets("chitanta diferenta")
Set WS6 = Worksheets("valuta")
Set WS7 = Worksheets("Baza de date Clienti")
' Vezi care este urmatorul rand
NextRow = WS2.Cells(Rows.Count, 1).End(xlUp).Row + 1
' Vezi care este urmatorul rand
NextRow = W7.Cells(Rows.Count, 1).End(xlUp).Row + 1
'Valorile importante din Registru facturi F2 -data, F3-nyumar factura, B10 -client, B11-reg com, B12-CUI, B13 adresa, B14 telefon, B15 email, B16 cont bancar, C36 suma achitat, C37 rest plata, D32 valuta facturii
WS2.Cells(NextRow, 1).Resize(1, 14).Value = Array(WS1.Range("F2"), WS1.Range("F3"), WS1.Range("B10"), Range("InvTot"), WS1.Range("B11"), WS1.Range("B12"), WS1.Range("B13"), WS1.Range("B14"), WS1.Range("B15"), WS1.Range("B16"), WS3.Range("C36"), WS3.Range("C37"), WS3.Range("D32"), WS3.Range("C38"))
'Valorile importante din Registru facturi F2 -data, F3-nyumar factura, B10 -client, B11-reg com, B12-CUI, B13 adresa, B14 telefon, B15 email, B16 cont bancar, C36 suma achitat, C37 rest plata, D32 valuta facturii
WS7.Cells(NextRow, 1).Resize(1, 14).Value = Array(WS7.Range("C5"), WS7.Range("C23"), WS7.Range("C24"), Range("InvTot"), WS7.Range("C25"), WS7.Range("C26"), WS7.Range("C28"), WS7.Range("C29"), WS7.Range("C30"), WS7.Range("C31"), WS7.Range("C32"), WS7.Range("C33"), WS7.Range("C6"), WS7.Range("C7"), WS7.Range("C8"), WS7.Range("C9"), WS7.Range("C10"), WS7.Range("C11"), WS7.Range("C12"), WS7.Range("C13"), WS7.Range("C14"), WS7.Range("C15"), WS7.Range("C16"), WS7.Range("C17"), WS7.Range("C18"), WS7.Range("C19"))
End Sub
Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Sub NextInvoice()
Range("F3").Value = Range("F3").Value + 1
Range("A18:A32").ClearContents
Worksheets("Customers").Range("C5:C36").ClearContents
Worksheets("Customers").Range("C38").ClearContents
End Sub
Sub SaveInvWithNewName()
Dim NewFN As Variant
Dim WS1 As Worksheet
Set WS1 = Worksheets("Invoice")
PostToRegister
' Convert all Formulas that Point to Other Sheets to Values
WS1.Range("B10:B16").Value = WS1.Range("B10:B16").Value
WS1.Range("C18").Value = WS1.Range("C18").Value
WS1.Range("D18").Value = WS1.Range("D18").Value
WS1.Range("F34").Value = WS1.Range("F34").Value
WS1.Range("B39").Value = WS1.Range("B39").Value
' Copy Invoice to new workbook
ActiveSheet.Copy
NewFN = "C:\Artemis\Inv\Inv" & Range("F3").Value & ".xlsx"
ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
' Back in the original Invoice worksheet, re-create the formulas
WS1.Range("B10:B16").NumberFormat = "General"
WS1.Range("$B$10").Formula = "=Customers!C23"
WS1.Range("$B$11").Formula = "=Customers!C24"
WS1.Range("$B$12").Formula = "=Customers!C25"
WS1.Range("$B$13").Formula = "=Customers!C28"
WS1.Range("$B$14").Formula = "=Customers!C29"
WS1.Range("$B$15").Formula = "=Customers!C30"
WS1.Range("$B$16").Formula = "=Customers!C31"
WS1.Range("$C$18").Formula = "=Customers!E16"
WS1.Range("$D$18").Formula = "=Customers!C32"
WS1.Range("$F$34").Formula = "=Customers!D32"
WS1.Range("$B$39").Formula = "=valuta!C4"
' Update the Invoice Number
NextInvoice
End Sub