'
Option Explicit
'
' vba Excel Archivia Fattura
Sub ArchiviaFattura()
Dim sigla, articolo
Dim campi, ritorno, quanti, valori
campi = Array("errore", "colonna sigla(0 se manca)", "articolo", "descrizione", "misura", "quantita", "prezzo", "importo", "nr. fattura fornitore", "nr protocollo azienda", "data fattura")
valori = Array("", "A", "B", "C", "D", "E", "F", "G", ".", "", ".", ".", ".")
ritorno = creamaskeraDef(campi, valori)
quanti = UBound(ritorno)
'
Dim colsigla, colart, coldescr, colum, colqta, colpre, colimp
colsigla = ritorno(1)
colart = ritorno(2)
coldescr = ritorno(3)
colum = ritorno(4)
colqta = ritorno(5)
colpre = ritorno(6)
colimp = ritorno(7)
'
If colsigla = 0 Then
sigla = InputBox("dammi la sigla aziendale del fornitore", "scelta", "")
End If
'MsgBox valori(8) & vbCrLf & valori(9) & vbCrLf & valori(10)
Dim quanter, contar, foglio, contenuto, colonnai, sfoglio, sriga
Set foglio = Sheets("fattura")
Set sfoglio = Sheets("fatture")
'
quanter = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
sriga = Range(sfoglio.UsedRange.Cells(sfoglio.UsedRange.Rows.Count, 1).Address).Row
sriga = sriga + 1
'
contar = 2
While contar <= quanter
sriga = sriga + 1
If colsigla <> 0 Then
sfoglio.Cells(sriga, "A").Value = foglio.Cells(contar, colsigla).Value ' sigla
Else
sfoglio.Cells(sriga, "A").Value = sigla ' sigla
End If
If colart <> 0 Then ' articolo
articolo = Trim(foglio.Cells(contar, colart).Value)
If IsNumeric(articolo) = True Then
sfoglio.Cells(sriga, "B").Value = "'" & articolo
Else
sfoglio.Cells(sriga, "B").Value = articolo
End If
End If
If coldescr <> 0 Then sfoglio.Cells(sriga, "c").Value = foglio.Cells(contar, coldescr).Value ' descr
If colum <> 0 Then sfoglio.Cells(sriga, "d").Value = foglio.Cells(contar, colum).Value ' um
If colqta <> 0 Then sfoglio.Cells(sriga, "e").Value = foglio.Cells(contar, colqta).Value ' qta
If colpre <> 0 Then sfoglio.Cells(sriga, "f").Value = foglio.Cells(contar, colpre).Value ' prezzo
If colimp <> 0 Then sfoglio.Cells(sriga, "G").Value = foglio.Cells(contar, colimp).Value ' importo
sfoglio.Cells(sriga, "H").Value = ActiveWorkbook.Name ' fornitore
sfoglio.Cells(sriga, "I").Value = ritorno(8) ' nr_fattura
sfoglio.Cells(sriga, "J").Value = ritorno(9) ' protocollo
sfoglio.Cells(sriga, "K").Value = ritorno(10) ' data ft
contar = contar + 1
Wend
'
'
End Sub
'
'
Function creamaskeraDef(campi, valori)
On Error GoTo esci
Dim H, IE, objtag, quanti, conta
quanti = UBound(campi)
ReDim ritorno(quanti)
ritorno(0) = "errore"
'
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate "about:blank" '
IE.Visible = True
IE.Height = 700
IE.Width = 550
IE.MenuBar = False
IE.Toolbar = False
IE.StatusBar = False
IE.resizable = True
'
IE.document.Title = "azienda - "
'
H = ""
H = H + "<html><body><center>"
H = H + " inserimento<br>"
H = H + "<FORM name=""mask"">"
For conta = 1 To quanti
H = H + campi(conta) + ": <input name=""" & campi(conta) & """ type=""text"" value=""" + valori(conta) + """><br>"
Next conta
H = H + "</FORM></body></html>"
IE.document.body.innerHTML = H
'
' Do While IE.readyState = 4: DoEvents: Loop
'
Do While IE.readyState = 4
'
conta = 0
For Each objtag In IE.document.all.tags("INPUT")
conta = conta + 1
ritorno(conta) = objtag.Value
Next
'
DoEvents
Loop
'
ritorno(0) = "risposta"
Set IE = Nothing
'
esci:
'
creamaskeraDef = ritorno
'
'
End Function
'
Nessun commento:
Posta un commento