Ajutor cu codul VBA

[sanacenter]

Buna ziua,

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

[csaba1960]

Buna

In atasament ai o rezolvare a problemei pe care le ai ridicat, daca am inteles bine ce doresti.
Aceasta adauga un rand la tabelul cu facturi, acelasi rand completeaza cu valoarea chitantei si adauga un rand nou la tabelul cu clienti.
Dupa care ar trebui sa se reseteze pagina Customers.

Cod: Selectaţi tot

Sub adaugFactura()
Dim NewRow As ListRow
Set NewRow = rf.ListObjects(1).ListRows.Add(AlwaysInsert:=True)
NewRow.Range = Array(f.Cells(3, 6), f.Cells(10, 2), f.Cells(33, 6), Format(f.Cells(12, 2), "@"), "", "", "", "", "", 0, 0, "", "", "", "", ""):
End Sub

Sub adaugChitanta()
Dim n  As Integer
n = rf.Cells(rf.Rows.Count, "B").End(xlUp).Row:
rf.Cells(n, 11) = c.Cells(36, 3): rf.Cells(n, 12) = c.Cells(37, 3):
End Sub

Sub adaugClienti()
Dim NewRow As ListRow
Set NewRow = bd.ListObjects(1).ListRows.Add(AlwaysInsert:=True)
NewRow.Range = Array(c.Cells(5, 3), c.Cells(23, 3), c.Cells(24, 3), f.Cells(33, 6), "", "", "", "", "", 0, 0, "", "", "", "", ""):
End Sub

Am inceput completarea fiecarui rand, nu este terminat, unde sunt "" mai completezi.
Unde in tabele este #N/A inseamna ca nu are suficienti elementi Array- ul de adaugare.

Am folosit la indicarea sheeturilor(c.cells(5,3)) CodeName, aceasta se completeaza in editorul VBA in casuta Properties a paginii.
Rutina care grupeaza cele trei de mai sus:

Cod: Selectaţi tot

Sub adaugTot()
unFilterTabele
adaugFactura
adaugChitanta
adaugClienti
'stergDate
End Sub

Aici rutina unFilterTabele anuleaza eventualele filtrari si TotalRows din tabele.
stergDate sterge datele dupe ce le-a inregistrat. Si aceasta este numai inceputa.

[sanacenter]

Multumesc mult , am sa verific si daca nu inteleg ceva revin cu intrebari.
O zi frumoasa Csaba