Hjælp til lidt VBA kodning i EXCEL
Dim Produkter(6, 4) As VariantDim Opdater As Boolean
Sub OPdaterSalg()
Opdater = True
opdaterkundedata
If Opdater = False Then Exit Sub
Timereg
If Opdater = False Then Exit Sub
rydark
End Sub
Sub opdaterkundedata()
Dim Antal As Byte
Antal = 0
BilAbbNormal:
For Each C In Range("D26:D29") ' Normal abb.
If C.Value <> "" Then
For Each CE In Range("B65:B69") ' hvis en af felterne med reg.nr er udfyldt, så ok
If CE.Value <> "" Then
GoTo BilSuper
End If
Next CE
MsgBox "Der skal indtastes Registrerings nummer på bil(er)"
Opdater = False
Exit Sub
End If
Next C
BilSuper:
If Range("D30").Value <> "" Or Range("D31").Value <> "" Then ' BilSuper og BilSuper kombirabat
For Each CE In Range("B65:B69") ' tjekker om der er mere end 1 bil
If CE.Value <> "" Then
Antal = Antal + 1
End If
Next
If Antal = 0 Then
MsgBox "Der Skal indtastes registrerings nummer på en' bil"
Exit Sub
ElseIf Antal > 1 Then
MsgBox "Der må kun indtastes registrerings nummer på en' bil" & vbLf _
& "Når der er valgt Bil Super"
Opdater = False
Exit Sub
End If
End If
DataOK:
Call FindProdukter ' her finder den de valgte produkter
Datasti = "E:\xx.mdb"
' Lav en forbindelse til Access databasen
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & Datasti & ";"
Set rs = New ADODB.Recordset
' Åben et emnemain data del
If MsgBox("Tjek om data er korrekt inden de indsættes i kundedatabasen?", vbQuestion + vbOKCancel, "Skal de indsættes i TimeReg?") = vbCancel Then
Opdater = False
Exit Sub
End If
With rs
.Open "DataFraExcel where [EmneNr]= '" & Range("J5").Value & "'", cn, adOpenKeyset, adLockOptimistic, adCmdTable
If .EOF Then
.AddNew ' Ny kunde
.Fields("EmneNr") = Range("J5").Value
Else
If MsgBox("Kunden eksisterer - skal kundebasisdata opdateres ? - ", vbYesNo, "Kunde eksisterer") = vbNo Then
Exit Sub
DEN SKAL STOPPE OP HVIS MAN SIGER NEJ _ DEN SKAL DERMED IKKE BARE FORSÆTTE KODEN
End If
End If
' tilføj værdier til hvert felt i recorden
.Fields("Navn") = Range("E4").Value
.Fields("Adresse") = Range("E5").Value
.Fields("PostNr") = Range("E6").Value
.Fields("TelefonNr") = Range("H7").Value
.Fields("Fødselsdag") = Range("J6").Value
.Fields("Phoner id") = Range("E7").Value
Phonerid skal være mindst på 4 cifre altså 1234 eller 5555 den skal komme med en MSG hvis ikke det er overholdt og ikke bare VBA egen fejlmeldning!!!
.Fields("Omsætning") = Range("G72").Value
' .Fields("Ikraftdato") = Range("J7").Value ' ved ikke om den skal bruges, den kommer på senere
.Fields("Regnr") = Range("D78").Value
.Fields("Kontonr") = Range("D79").Value
.Fields("Cpr") = Range("D80").Value
.Fields("Dagsdato") = Range("J4").Value
.Fields("Kronisksyg") = Trim(Range("G78").Value)
.Fields("Bemærkning") = Range("B83").Value & Range("B84").Value
DENNE KODE NEDENFOR SKAL ÆNDRES SÅ DET ER TILLADT AT INDTASTE 10 PRODUKTER - DER ER DOG FORSAT KUN PLADS TIL BILREG PÅ 5 PRODUKTER - HVIS DER ER INDTASTET MERE END 10 SKAL DEN KOMME MED EN fejl/MSG:
For I = 1 To 6
If I < 6Then .Fields("Bil regnr" & I) = Range("B" & 64 + I).Value ' der er kun 5 biler
.Fields("Produktnr" & I) = Produkter(I, 2)
.Fields("Produkttekst" & I) = Produkter(I, 3)
.Fields("Ikraftdato" & I) = Range("J7").Value
' her kan indsættes flere i serier
Next
' tilpas til aktuel tabel
.Update ' gem den nye record
.Close
'nokundeupdate:
' If MsgBox("Kunden eksisterer - skal Salgsdata opdateres ?", vbYesNo, "Kunde eksisterer") = vbNo Then
' GoTo kundeslut
' End If
'opdaterkundedata:
' Åben et emnesub data del
' With rs
' .Open "tblemnesub where [EmneNr]= '" & Range("J5").Value & "'", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' If Not .EOF Then
' cn.Execute "DELETE FROM tblEmneSub " & _
' "WHERE [EmneNr]= '" & Range("J5").Value & "'", iAffected, adExecuteNoRecords
' End If
'--- læs ind en masse
' For I = 11 To 62
' If Len(Range("D" & I).Formula) > 0 Then
' .AddNew ' Nyt produkt
' .Fields("EmneNr") = Range("J5").Value
' .Fields("Produktnr") = Range("E" & I).Value
' .Fields("Produkttekst") = Range("F" & I).Value
' .Fields("antal") = Range("D" & I).Value
' .Fields("pris") = Range("J" & I).Value
' .Update ' gem den nye record
' End If
' Next
' .Close
End With
'
'
Set rs = Nothing
End Sub
DENNE kode nedenfor SKAL ÆNDRES SÅ DET ER TILLADT AT INDTASTE 10 produkter i stedet for 6
Public Sub FindProdukter()
Dim X As Byte
X = 1
For Each C In Range("D11:D62")
If C <> "" Then
Produkter(X, 1) = C ' denne indeholder antallet af det enkelte produkt , skal det ikke bruges. ?
For I = 2 To 3
Produkter(X, I) = C.Offset(0, I - 1)
Next
X = X + 1
End If
Next
End Sub
Sub Timereg()
If MsgBox("Tjek om salget er korrekt inden der udskrives?", vbQuestion + vbOKCancel, "Slet infomation?") = vbCancel Then
Opdater = False
Exit Sub
End If
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
If MsgBox("Er du sikker på data er korrekt?", vbQuestion + vbOKCancel, "Skal de indsættes i TimeReg?") = vbCancel Then
Exit Sub
End If
Datasti = "E:\XX.mdb"
' Lav en forbindelse til Access databasen
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & Datasti & ";"
' Åben et recordset
Set rs = New ADODB.Recordset
rs.Open "timeregistrering", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' alle records i en tabel
With rs
.AddNew ' tilføj ny record
' tilføj værdier til hvert felt i recorden
.Fields("Medarbejderid") = Range("E7").Value
.Fields("Projektid") = Range("C5").Value
.Fields("Dato") = Range("J4").Value
.Fields("Salg") = Range("G72").Value
.Fields("Kunde") = Range("E4").Value
' tilpas til aktuel tabel
.Update ' gem den nye record
End With
rs.Close ' luk skidtet
Set rs = Nothing
cn.Close ' også her
Set cn = Nothing
' slut prut finale
End Sub
Sub rydark()
' rydark Makro
' Makro indspillet 10-09-2002 af DK7141
'
Range("E4:E6,H7,J5:J6,D11:D54,D57:D62,B65:D69,D78:D80,H77:H80,B83:B84").Activate
Selection.ClearContents
'
End Sub
Jeg har skrvet ind i koden hvad det er der skal laves!! JEg er ikke selv en haj til VBA - derfor har jeg lidt svært ved at gennemskue det;-)
