Autummeering af fakturaer

Fortløbende fakturanr - hvis fakturanr indgår i filnavn - kan det højeste nr. godt fanges - +1 til nyeste.

Vil tilføjelse af en Annuller-knap ïkke kunne forhindre dette.


Men du er velkommen til at det nødvendige til: pb@supertekst-it.dk

Det er sådan set også en fin løsning, hvis ikke du har en bedre ide e.l. jeg er åben for alt.

Nej ikke en annuller knap. For man kan jo hente oplysninger til userformen og trykke ok, derved kommer nogle nødvendige oplysninger også med på fakturaen som bliver hentet. Og først derefter finder man ud af at man måske ikke ville lave den faktura alligevel.

Jeg sender den lige til dig...

Er modtaget - skal se på mulighederne.

ThisWorkbook:
=============
Private Sub Auto_Open()
AddIns.Add Filename:= _
        "C:\Programmer\Microsoft Office\Office11\Xlstart\rsobb.xla"
    AddIns("rsobb").Installed = True
End Sub
Private Sub Workbook_Open()
    Load UserForm4
    UserForm4.Show 0              '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
End Sub

Userform4:
==========
Rem Version 6
Rem =========
Const DataSti = "H:\Data.xls"      'tilpasses
Const gemSomSti = "H:\Faktura\"          'tilpasses

Dim rækIArk, aktuelleRæk
Dim dataarkXLS As Object, kXLS As Object, passFlag As Boolean

Dim fakturaNr                                      '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Private Sub udførGem()
Dim sti As String, gemMappe As String, uMappe As String

Rem check drev
    On Error GoTo sti_Fejl

    sti = gemSomSti
    If Right(sti, 1) <> "\" Then
        sti = sti + "\"
    End If
   

Rem KundeMappe Ok - gem filen
    On Error GoTo fejlGemSti
    ActiveWorkbook.SaveAs sti + "Tilbud " + f_projekt + " " + Me.f_kundeNr + " pr. " + CStr(Format(Now(), "dd-mm-yyyy hhmmss")) + ".xls" '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX

Rem Luk userform
    CommandButton2_Click                            'kan fjernes, hvis lukning ikke ønskes
    Exit Sub


fejlGemSti:
    MsgBox ("Fejl i GemSti - sandsynligvis illegalt tegn i årstal")
    Exit Sub
   
sti_Fejl:
    MsgBox ("Fejl i en sti-angivelse")
End Sub
Private Sub f_kundeNr_Enter()
    Me.f_kundeNavn = ""
End Sub
Private Sub f_kundeNr_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If passFlag = False Then
        passFlag = True
        If Me.f_kundeNr <> "" And IsNumeric(Me.f_kundeNr) = True Then
            Me.f_kundeNavn = søgKunde(Val(Me.f_kundeNr))
            Me.f_adresse = søgKundeA(Val(Me.f_kundeNr))
            Me.f_postnr = søgKundeP(Val(Me.f_kundeNr))
            Me.f_by = søgKundeB(Val(Me.f_kundeNr))
       
            If Me.f_kundeNavn <> "" Then
                    Me.f_kundeNr.SetFocus
            End If
           
            kXLS.Quit
            Set kXLS = Nothing
        End If
        passFlag = False
    End If
End Sub
Private Sub CommandButton2_Click()          'Annuller
    Unload UserForm4
End Sub
Private Function søgKunde(knr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open DataSti, False, True
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = knr Then
                søgKunde = .Cells(r, 2)
                Exit Function
            End If
        Next r
    End With
    søgKunde = ""
    MsgBox ("Det indtastede kundenr. kunne ikke findes")
End Function
Private Function søgKundeA(knr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open DataSti, False, True
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = knr Then
                søgKundeA = .Cells(r, 3)
                Exit Function
            End If
        Next r
    End With
    søgKundeA = ""
End Function
Private Function søgKundeP(knr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open DataSti, False, True
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = knr Then
                søgKundeP = .Cells(r, 4)
                Exit Function
            End If
        Next r
    End With
    søgKundeP = ""
End Function
Private Function søgKundeB(knr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open DataSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = knr Then
                søgKundeB = .Cells(r, 5)
                Exit Function
            End If
        Next r
    End With
    søgKundeB = ""
End Function
Private Function findGemMappe(sti, knr)
Rem Søger efter mappe med navnet: Kundenr+BLANK i begyndelsen af MappeNavnet
    Dim fs, f, f1, fc, s, xKnr
    knr = CStr(Val(knr))                            'fjerner foranstillede nuller
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(sti)
    Set fc = f.SubFolders
    For Each f1 In fc
        If InStr(f1.Name, knr + " ") = 1 Or InStr(f1.Name, knr) = 1 Then
            findGemMappe = f1.Name                  'Fulde mappeNavn returneres..
            Exit Function
        End If
    Next
    findGemMappe = ""
End Function
Private Sub UserForm_activate()
    fakturaNr = findFakturanr              '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    Me.CommandButton3.Enabled = False      '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
   
    indlæsprojekt
    Me.f_kundeNr.SetFocus
End Sub
Private Function findFakturanr()    '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Rem Søger efter mappe med navnet: Kundenr+BLANK i begyndelsen af MappeNavnet
    Dim fs, f, f1, fc, count
   
    count = 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(gemSomSti)
    Set fc = f.Files
    For Each f1 In fc
        count = count + 1
    Next
    findFakturanr = count + 1
End Function
Private Sub indlæsprojekt()
    On Error GoTo fejlprojektSti
   
    Set dataarkXLS = CreateObject("Excel.application")
    With dataarkXLS
        .Workbooks.Open DataSti, False, True
        .Sheets(3).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 11 To Max
            Me.f_projekt.AddItem .Cells(r, 1)
        Next r
    End With
   
    dataarkXLS.Quit
    Set dataarkXLS = Nothing
    Exit Sub

fejlprojektSti:
    MsgBox ("Fejl i sti t/projekt.xls")
End Sub
Private Sub CommandButton1_Click()
    If Me.f_kundeNr.Value <> "" And _
        Me.f_projekt.Value <> "" Then
            OpdaterIArk                      '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
            Me.CommandButton3.Enabled = True  '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    Else
        MsgBox ("Alle felter skal udfyldes")
    End If
End Sub
Private Sub OpdaterIArk()
    Sheets(1).Activate
    Cells(9, 1) = Me.f_kundeNr.Value
    Cells(10, 1) = Me.f_adresse
    Cells(11, 1) = Me.f_postnr + " " + Me.f_by
    Cells(10, 8) = fakturaNr                      '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
         
    Cells(11, 8) = Me.f_kundeNr.Value
    Cells(58, 5) = "'00000" + Me.f_kundeNr.Value
    Cells(14, 1) = Me.f_projekt.Value
End Sub
Private Sub CommandButton3_Click()                '<-XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    udførGem
    Me.CommandButton3.Enabled = False
End Sub

Hey

Efter hurtig test er der lige et par spørgsmål.

1. Hvordan finder den næste fakturanr. ? (ren nysgerrighed)
2. Hvad er det sidste nr. i filnavnet de får ?
3. Når man åbner xls-filen efter den er blevet gemt starter den userformen igen ?
4. Det er ikke helt den ønskede funktion vedr. at man kan fortryde sit valg af faktura. Jeg mener at man som oftest først finder ud af dette efter man har lukket userformen og er begyndt at tilføje linier m.v. til fakturaen
5. Så er der er problem fra før du har hjulpet mig. Den åbner min data-fil skrivebeskyttet hver gang jeg bruger min fakturaskabelon ?


Håber du har tid til at kigge på disse...

1. den tæller antallet af fakturafiler
2. tidsstempel - TimeMinutSek - entydig identifikation
3. ? - det kan den gøre
4. Du kan godt arbejde med faktura - selvom userformen er åben - årsag 0'et i ThisWorkbook
5. Skal se på det..