Sub variabelen



Dovnload 73.92 Kb.
Datum17.08.2016
Grootte73.92 Kb.
Public server, database, jaar, periodev, periodetm, einderij, echteinderij

Sub init()

Call variabelen

Call ververs_data

Call ververs_projecten

Call UpDateAll

Worksheets("Vastgoedportefeuille").Activate

Call FindLastRow

Call hiderow

End Sub
Sub variabelen()

server = Range("server").Value

database = Range("database").Value

periodev = Range("periodev").Value

periodetm = Range("periodetm").Value

jaar = Range("jaar").Value

End Sub
Public Sub ververs_data()

' QueryTable object

Dim qt As QueryTable

' SQL Statement medewerkers

Sql1 = "SELECT * from sumatra.css_beheerafrekening_project_vastgoed "

Sql1 = Sql1 & " where jaar= " & jaar

Sql1 = Sql1 & " and periode>= " & periodev & " and periode<= " & periodetm

sqlstring = Sql1 '& sql2 & sql3 & sql4

' Connectiestring (ODBC)

' naam en wachtwoord leeg voor NT

connstring = "ODBC;DRIVER=SQL Server;SERVER=" & server & ";UID=sumatra;PWD=sumatra;APP=Microsoft Office 2003;WSID=NTSISO3;DATABASE=" & database

Sheets("data").Visible = True

Worksheets("data").Activate

Cells.Select

Selection.ClearContents

With ActiveSheet.QueryTables.Add(Connection:=connstring, Destination:=Range("A1"), Sql:=sqlstring)

.FieldNames = True

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.BackgroundQuery = True

.RefreshStyle = xlOverwriteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.PreserveColumnInfo = True

.Refresh BackgroundQuery:=False

End With

End Sub
Public Sub ververs_projecten()

' QueryTable object

Dim qt As QueryTable

' SQL Statement medewerkers

Sql1 = "SELECT projectnr,description, ltrim(rtrim(projectnr))+'-'+description as omschrijving,status from prproject "

'Sql1 = Sql1 & " where jaar= " & jaar

'Sql1 = Sql1 & " and periode>= " & periodev & " and periode<= " & periodetm

sqlstring = Sql1 '& sql2 & sql3 & sql4

' Connectiestring (ODBC)

' naam en wachtwoord leeg voor NT

connstring = "ODBC;DRIVER=SQL Server;SERVER=" & server & ";UID=sumatra;PWD=sumatra;APP=Microsoft Office 2003;WSID=NTSISO3;DATABASE=" & database

Sheets("projecten").Visible = True

Worksheets("projecten").Activate

Cells.Select

Selection.ClearContents

With ActiveSheet.QueryTables.Add(Connection:=connstring, Destination:=Range("A1"), Sql:=sqlstring)

.FieldNames = True

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.BackgroundQuery = True

.RefreshStyle = xlOverwriteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.PreserveColumnInfo = True

.Refresh BackgroundQuery:=False

End With


End Sub


Sub UpDateAll()

Dim PT As PivotTable

Dim ws As Worksheet

Dim ireply As Integer

For Each ws In Worksheets

'ws.Select

For Each PT In ws.PivotTables

' PT.PivotSelect (PT.DataFields(1))

' ireply = MsgBox("Refresh This One", vbYesNo + vbQuestion)

PT.RefreshTable

Next PT

Next ws


End Sub
Sub FindLastRow()

Application.ScreenUpdating = False

'eerst weer alle rijen zichtbaar

Rows("7:300").Select

Selection.EntireRow.Hidden = False

Cells(1, 1).Select

einderij = 0

einderij = Range("A65536").End(xlUp).Row

echteinderij = einderij

For x = 8 To einderij

If Cells(x, 1).Value = "" Or LCase(Cells(x, 1).Value) = "(blank)" Or LCase(Cells(x, 1).Value) = "(leeg)" Or LCase(Cells(x, 1).Value) = "grand total" Or LCase(Cells(x, 1).Value) = "totaal" Then

' "IsNumeric(Cells(x, 1).Value) = 0 Then

echteinderij = echteinderij - 1

End If


Next

echteinderij = echteinderij

End Sub
Sub hiderow()

'vervolgens niet waarde rijen verberngen

reeks = "A" & echteinderij + 1 & ":A" & einderij - 1

Set Rng = Range(reeks)


'-For x = echteinderij To einderij

For Each c In Rng

c.EntireRow.Hidden = True

Next c


Application.ScreenUpdating = True

End Sub


Excel VBA

OPSTARTPARAMETERS

/e

LEEG SCHERM



/automation

GEEN ADDINNS

/i

VOLLEDIG SCHERM



/m

START MACRO DIRECT OP

/s

SAFE MODE




* LAATSTE RIJ VINDEN

Sub FindLastRow()

einderij = 0
einderij = Range("B65536").End(xlUp).Row

End Sub
Cellen onder elkaar tbv IN query

LastRow = Worksheets("instellingen").Range("B65536").End(xlUp).Row

reeks = "B5:B" & LastRow

If LastRow = 5 Then

land = Worksheets("instellingen").Cells(5, 2).Value

Else

land = Join(WorksheetFunction.Transpose(Worksheets("instellingen").Range(reeks).Value), "','")



End If

sql1 = "select * from CSS_Orders_FR where jaar= " & jaar

sql1 = sql1 & " and land in ('" & land & "') order by naam,ordernr"
*VERTIKAAL ZOEKEN

Application.VLookup(cell, Workbooks("loonjournaalposttemplate.xls").Sheets("ENERGIE").Range("kostendrager"), 2, False)


*START ORBISTAAK

Sub startorbistaak()

If bestandgrootte < 10 Then Exit Sub

query = "exec [dbo].[_Orbis_StartTaak] " & Range("orbistaak").Value

programma = osqlmap & "\osql.exe -Uorbis -Porbis -S" & server & " -d" & database & " -Q" & Chr(34) & query & Chr(34)

uitvoer = programma

retval = Shell(uitvoer, 2)
End Sub

*CHECKVALUES

Sub checkvalues()


Dim LR As Long, i As Long

legewaardes = 0

kleur = 192

LR = Range("B" & Rows.Count).End(xlUp).Row

For i = 8 To LR

'straat


With Range("B" & i)

If .Value = "" Then

legewaardes = 1

.Interior.Color = RGB(255, 0, 0)

Else: .Interior.Color = RGB(192, 192, 192)

End If


End With
*GUID

Sub GenerateGUID()

'Dim strguid As String

Set TypeLib = CreateObject("Scriptlet.TypeLib")

strguid = Left(TypeLib.GUID, 38)

Set TypeLib = Nothing

End Sub
*SQL DATA OPHALEN

Public Sub ververs_medewerkers()

' QueryTable object

Dim qt As QueryTable

server = Worksheets("instellingen").Cells(1, 2).Value

database = Worksheets("instellingen").Cells(2, 2).Value

' SQL Statement medewerkers

sql1 = "SELECT * from humres humres "

sqlstring = sql1 ‘& sql2 & sql3 & sql4

' Connectiestring (ODBC)

' naam en wachtwoord leeg voor NT

connstring = "ODBC;DRIVER=SQL Server;SERVER=" & server & ";UID=orbis;PWD=orbis;APP=Microsoft Office 2003;WSID=NTSISO3;DATABASE=" & database

Sheets("medewerkers").Visible = True

Worksheets("medewerkers").Activate

Cells.Select

Selection.ClearContents

With ActiveSheet.QueryTables.Add(Connection:=connstring, Destination:=Range("A1"), Sql:=sqlstring)

.FieldNames = False

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.BackgroundQuery = True

.RefreshStyle = xlOverwriteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.PreserveColumnInfo = True

.Refresh BackgroundQuery:=False

End With

End Sub
SQL DATA BIJWERKEN

Sub bijwerken()

' QueryTable object

Dim rst As ADODB.Recordset

Dim Cnxn As ADODB.Connection

Dim strCnxn As String

Dim strSQL As String


server = "srv01-Sql" 'Worksheets("instellingen").Cells(1, 2).Value

database = "100" 'Worksheets("instellingen").Cells(2, 2).Value

' Connectiestring (ODBC)

' naam en wachtwoord leeg voor NT

Set Cnxn = New ADODB.Connection

strCnxn = "Provider=sqloledb;Data Source=" & server & ";Initial Catalog=" & database & ";User Id=reports;Password=reports; "

Cnxn.Open strCnxn
Set rst = New ADODB.Recordset

strSQL = sqlstring

rst.Open strSQL, Cnxn, adOpenDynamic, adLockOptimistic, adCmdText

Cnxn.Close

Set rst = Nothing

Set Cnxn = Nothing

End Sub

*TEMPPATH

Public Declare Function GetTempPath _

Lib "kernel32" Alias "GetTempPathA" _

(ByVal nBufferLength As Long, _

ByVal lpBuffer As String) As Long
Public Const MAX_PATH As Long = 260
Function TempPath() As String

TempPath = String$(MAX_PATH, Chr$(0))

GetTempPath MAX_PATH, TempPath

TempPath = Replace(TempPath, Chr$(0), "")

End Function
pad = TempPath

bestand = pad & "planningtemp.txt"


*UNPROTECT

Sub unprt()

test5 = InputBox("wachtwoord", "ww", Default)

Sheets("planning").Unprotect Password:=test5

Application.ScreenUpdating = True

Application.EnableEvents = True

End Sub
*SHEETONCHANGE

Private Sub Worksheet_Change(ByVal Target As Range)


Dim myIntersect As Range

Dim myCell As Range

Dim RngToInspect As Range

Application.ScreenUpdating = False

Application.EnableEvents = False

Call UnlockMyRanges

Application.EnableEvents = True

If Target.Address = Range("opdrachtformulier").Address Then

'If Target.Address = "$I$3" Then

On Error Resume Next

Application.EnableEvents = False

Call hyperlinkinsert

Call opmaakhyperlink

Application.EnableEvents = True

ActiveSheet.Cells(8, 1).Select

On Error GoTo 0

'Set IRange = Range("B8:O500")

'Set Target = Range("B8:O500")

End If

Application.ScreenUpdating = True



If Target.Cells.Count > 1 Or IsEmpty(Target) Then

Application.EnableEvents = True

Exit Sub

End If


Application.ScreenUpdating = True

Application.EnableEvents = True

End Sub

*HYPERLINKINSERT

Sub hyperlinkinsert()

server = Worksheets("instellingen").Cells(1, 2).Value

database = "001" 'Worksheets("instellingen").Cells(2, 2).Value

synurl = Worksheets("instellingen").Cells(3, 2).Value

synserver = Worksheets("instellingen").Cells(4, 2).Value

Cell = Range("opdrachtformulier").Value

On Error Resume Next

ID = Application.VLookup(Cell, Sheets("opdrachtformulieren").Range("opdrachtrange"), 5, False)
Range("hyperlink").Select

Hyperlink = "http://" & synserver & "/" & synurl & "/docs/EPRequest.asp?Action=1&ID=%7b" & ID & "%7d"

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Hyperlink

End Sub
*INSQLPLAATSENMBV OSQL

Sub in_sql_plaatsen()

bestandgrootte = FileLen(bestand)

If bestandgrootte < 10 Then Exit Sub

programma = osqlmap & "\osql.exe -Uorbis -Porbis -S" & server & " -d" & database & " -i" & bestand

uitvoer = programma

retval = Shell(uitvoer, 2)


End Sub
*SAFEXML

Function getSafeXML(strInput) As String

Dim iCount As Long

Dim code As Integer

Dim strOut As String
For iCount = 1 To Len(strInput)

code = Asc(Mid$(strInput, iCount, 1))

If ((code < 65) And (code <> 32)) Or ((code > 90) And (code < 97)) Or (code > 123) Then

strOut = strOut & "&#" & Asc(Mid$(strInput, iCount, 1)) & ";"

Else

strOut = strOut & Mid$(strInput, iCount, 1)



End If

Next
getSafeXML = strOut


End Function
*INSERT INTO FROM EXCEL
For x = 8 To einderij

If Cells(x, 11).Value <> "" And Cells(x, 12).Value <> "" And Cells(x, 13).Value <> "" Then

sqlinsert = "insert into planningen(straat,nummer,[m2],datum,begintijd,eindtijd,IDopdracht,medewerker1,medewerker2,type,plaats,itemnumberID) values("

sqlinsert = sqlinsert & quote & Cells(x, 1).Value & quote & "," & quote & Cells(x, 2).Value & quote & "," & quote & Cells(x, 3).Value & quote

sqlinsert = sqlinsert & "," & quote & Cells(x, 11).Value & quote & "," & quote & Format(Cells(x, 12).Value, "hh:mm") & quote & "," & quote & Format(Cells(x, 13).Value, "hh:mm") & quote

sqlinsert = sqlinsert & "," & Cells(x, 14).Value & "," & Cells(x, 15).Value & "," & Cells(x, 16).Value & "," & "8904" & ",'" & plaats & "','" & Cells(x, 17).Value & "')"

Print #1, sqlinsert

End If


Next
*PIVOTOPBOUW

Sub pivotopbouw()

Dim lngR As Long '#ROWS-ALWAYS USE LONG TO AVOID MAX INTEGER ERROR

Dim intC As Integer '#COLUMNS

'SET VALS

Sheets("gegevens").Select 'SELECT SHEET TO CREATE PIVOT TABLE ON

Range("A1").Select 'SELECT A CELL IN ACTIVE DATA RANGE

lngR = Range("A1").CurrentRegion.Rows.Count 'GET ROW COUNT ON ACTIVE SHEET

intC = Range("A1").CurrentRegion.Columns.Count 'GET COLUMN COUNT ON ACTIVE SHEET

'******************* VERSION 2 SPECIFIC DESTINATION SHEET ********************************

'*****************************************************************************************

' Sheets.Add 'CREATE A NEW SHEET OR ASSIGN EXISTING ONE TO VARIABLE

strDynamicSheet = "spil" 'ASSIGN DYNAMIC SHEET

sheetname = "gegevens"

'

' 'CREAT PIVOT



Sheets("spil").Select 'GO BACK TO PIVOT DATA SHEET

Cells.Select

Selection.Delete Shift:=xlUp

Sheets("gegevens").Select 'GO BACK TO PIVOT DATA SHEET

ActiveSheet.PivotTableWizard xlDatabase, Range("A1:AM10000"), TableDestination:="SPIL!R10C1", TableName:="draaitabel1"

'DAta field toekennen

ActiveSheet.PivotTables("Draaitabel1").AddDataField ActiveSheet.PivotTables( _

"Draaitabel1").PivotFields("uniqueid"), "Aantal", xlCount

' ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _

' "gegevens!R1C1:R10000C34").CreatePivotTable TableDestination:= _

' "Spil!R10C1", TableName:="Draaitabel1", DefaultVersion:= _

' xlPivotTableVersion10

ActiveWorkbook.ShowPivotTableFieldList = False

End Sub
*USERFORM

jaarvanaf = UserForm1.Controls("jaarvan").Value

Jaartot = UserForm1.Controls("jaartot").Value


*REMOVESUBTOTAL

Selection.RemoveSubtotal


Sub MoveSubtotals()

Dim rCell As Range

Dim rng As Range

Dim iCol As Integer

Dim iOffset As Integer
iCol = 9 '19 is Column S

iOffset = 1 'Positives go right, negatives go left

Set rng = Intersect(Selection.CurrentRegion, Columns(iCol))

For Each rCell In rng

If InStr(rCell.Formula, "SUBTOTAL") Then

rCell.Offset(0, iOffset).Formula = _

rCell.Formula

rCell.ClearContents

End If

Next


End Sub
*XMLFILE FROM EXCEL

Sub MakeXML()


' create an XML file from an Excel table

Dim MyRow As Integer, MyCol As Integer, Temp As String, YesNo As Variant, DefFolder As String

Dim XMLFileName As String, XMLRecSetName As String, MyLF As String, RTC1 As Integer

Dim RangeOne As String, RangeTwo As String, Tt As String, FldName(99) As String, pad As String


datum = InputBox("Geef datum in de vorm dd-mm-jjjj", vbOKOnly, lastday)

datum = Right(datum, 4) + "-" + Mid(datum, 4, 2) + "-" + Left(datum, 2)

' moeder = Worksheets("instellingen").Cells(5, 2).Value

pad = Workbooks(1).Path & "\"

' datum = Replace(Worksheets("instellingen").Cells(9, 2).Value, "/", "-")
MyLF = Chr(10) & Chr(13) ' enter
bestand = pad & "Loonjournaalpost_" & admin & ".XML"

Open bestand For Output As #1


'datum = lastday

btw = Cells(2, 14).Value

factcode = Cells(3, 14).Value

' OPSLAG AK

Print #1, ""

Print #1, ""

Print #1, ""

Print #1, ""

Print #1, ""

Print #1, "" & datum & ""

Print #1, "" & Cells(4, 1).Value & ""

For rij = 12 To einderij - 1 ' aantal rijen, totaalregel NIET

If Cells(rij, 1).Value <> "" Then

' For kolom = 1 To 10 ' aantal kolommen

'Print #1, "" & getSafeXML(Cells(rij, 1)) & ""

'Print #1, ""

'DEBET

If Cells(rij, 10).Value <> 0 Then



Print #1, ""

Print #1, "" & datum & ""

Print #1, "" & Cells(4, 1).Value & ""

Print #1, ""

'Print #1, ""

'Print #1, ""

'Print #1, "
"

Print #1, ""

Print #1, ""

Print #1, "" & Replace(Round(Cells(rij, 8).Value, 2), ",", ".") & ""

Print #1, ""

Print #1, ""

End If

If Cells(rij, 14).Value <> 0 Then



Print #1, ""

Print #1, "" & datum & ""

Print #1, "" & Cells(4, 1).Value & ""

Print #1, ""

'Print #1, ""

'Print #1, ""

'Print #1, "
"

Print #1, ""

Print #1, ""

Print #1, "" & Replace(Round(Cells(rij, 12).Value, 2), ",", ".") & ""

Print #1, ""

Print #1, ""

End If

End If


Next rij

Print #1, ""

Print #1, ""

Close #1


' OPSLAG AK

' EINDE rekening courant eigenaar BV

End Sub
*IMPORT EXACT

Sub import_exact(bestand)


' start nu msxsl om het kale xml-bestand om te zetten naar exact leesbaar formaat

Dim RetVal

exactpad = Chr(34) & "c:\program files\exact software\bin\asimport.exe" & Chr(34)
programma = exactpad & " -r" & server & " -D" & admin & " -u -~ I -URL" & bestand & Chr(34) & " -Tglentries" '& " -Oauto"
'$asimport= chr(034) & " -r" & $server & " -D" & $exactadmin & " -u -~ I -URL" & $file & " -T" & $topic & " -Oauto"
uitvoer = programma
RetVal = Shell(uitvoer, 2)

End Sub
*FIND DSN

Sub find_DSN()

DSNArray = Worksheets("Sheet1").UsedRange.PivotTable.SourceData

DSN = Msg
*HIDE KOLOMMEN BASED ON CELL VALUE

Sub hide_unhide()


Dim rng As Range

Dim c As Range

'hier staat dus rij waar gekeken wordt of er een lege waarde staat

Set rng = Range("D2:T2")


For Each ws In Worksheets

Select Case ws.Name

Case "SLA SPIL", "NONSLA SPIL", "SPIL BU"

For Each c In rng

If c.Value <> "" Then

c.EntireColumn.Hidden = False

Else

c.EntireColumn.Hidden = True



End If

Next c


End Select

Next ws
End Sub


*FILTER

Sub filtertoepassen()

Rows("1:1").Select

Selection.AutoFilter

Selection.AutoFilter Field:=4, Criteria1:="<>01-01*", Operator:=xlAnd

End Sub
*LEGE CELLEN VULLEN MET WAARDEN ERBOVEN

Columns("I:I").Select

Selection.SpecialCells(xlCellTypeBlanks).Select

Selection.FormulaR1C1 = "=R[-1]C"

of
F5-

special-

lege waarden-

type =

pijltje omhoog



ctrl-enter
*LEGE RIJEN VERWIJDEREN

Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete



*TEKSTNAARKOLOMMEN

Workbooks(1).Activate

Columns("A:A").Select

Selection.texttocolumns Destination:=Range("A1"), DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _

Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _

:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), _

Array(7, 2), Array(8, 2), Array(9, 2), Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2 _

), Array(14, 2), Array(15, 2), Array(16, 2), Array(17, 2), Array(18, 2), Array(19, 2), Array _

(20, 2), Array(21, 2), Array(22, 2), Array(23, 2), Array(24, 2), Array(25, 2), Array(26, 2), _

Array(27, 2), Array(28, 2), Array(29, 2), Array(30, 2), Array(31, 2), Array(32, 2), Array( _

33, 2), Array(34, 2), Array(35, 2), Array(36, 2), Array(37, 2), Array(38, 2), Array(39, 2), _

Array(40, 2), Array(41, 2), Array(42, 2), Array(43, 2), Array(44, 2), Array(45, 2), Array( _

46, 2), Array(47, 2)), TrailingMinusNumbers:=True



*PIVOTTABLE REFRESH

Sub UpDateAll()

Dim PT As PivotTable

Dim ws As Worksheet

Dim ireply As Integer

For Each ws In Worksheets

'ws.Select

For Each PT In ws.PivotTables

' PT.PivotSelect (PT.DataFields(1))

' ireply = MsgBox("Refresh This One", vbYesNo + vbQuestion)

PT.RefreshTable

Next PT


Next ws

End Sub
*ELFPROEF

=ALS(EN(LENGTE(A1)<8;EN(ISGETAL(A1);A1>=1));"giro"; ALS(OF(LENGTE(A1)>9;OF(LENGTE(A1)<2));"fout";(ALS((REST(((9*(DEEL(A1;1;1)))+(8*(DEEL(A1;2;1)))+(7*(DEEL(A1;3;1)))+(6*(DEEL(A1;4;1)))+(5*(DEEL(A1;5;1)))+(4*(DEEL(A1;6;1)))+(3*(DEEL(A1;7;1)))+(2*(DEEL(A1;8;1)))+(DEEL(A1;9;1)));11))=0;"goed";"fout"))))
*EXCELBESTAND ALS DOCUMENT IN DATABASE (SYNERGYDOC)

Sub saveindb()


'eerst in tijdelijke tabel opslaan

Set cn = New ADODB.Connection

cn.Open "Provider=SQLOLEDB;data Source=hanzesql2;Initial Catalog=synaccept;User Id=debman4u;Password=debman4u"

Set rs = New ADODB.Recordset

rs.Open "Select * from css_overzichten where bestandsnaam='1'", cn, adOpenKeyset, adLockOptimistic

Set mstream = New ADODB.Stream

mstream.Type = adTypeBinary

mstream.Open

mstream.LoadFromFile "C:\PlaatsingsOverzicht\IMoverzicht_bijgewerkt.xls"

rs.Fields("file").Value = mstream.Read

rs.Update

rs.Close


cn.Close

'vervolgens vaststaand docnumber bijwerken met juiste waarde

getConn

'Set myRs = dbConn.Execute("select project_id, crm5.project.name, crm5.currency.name as valuta, long06 as startdatum, long07 as einddatum, long08 as looptijd, double05 as bedrag from crm5.project, crm5.udprojectsmall, crm5.currency where userdef_id = udprojectsmall_id and long05 = currency_id and long06 <> 0 and long07 <> 0 and long08 <> 0 and double05 <> 0 and crm5.project.name='" & aFonds & "';")



updatesql = "update bacodiscussions"

updatesql = updatesql & " Set document = [file]"

updatesql = updatesql & " ,filename='intermediair overzicht bijgewerkt.xls'"

updatesql = updatesql & " ,subject='intermediair overzicht bijgewerkt ' +convert(varchar(10),getdate(),105)+'.xls'"

updatesql = updatesql & " from bacodiscussions, css_overzichten"

updatesql = updatesql & " where bacodiscussions.hid = 21330"

updatesql = updatesql & " and css_overzichten.bestandsnaam=1 "

Set myRs = dbConn.Execute(updatesql)

Set myRs = Nothing

dbConn.Close

End Sub

Datum formules

=DATUM(Instellingen!$B$1;3*Instellingen!$B$2-2; 1)

1e dag van ingegeven kwartaal, hierin zijn

$b$1 : jaar

$b$2 : kwartaal nummer (1-4)

=DATUM(Instellingen!$B$1;3*Instellingen!$B$2+1;0)

laatste dag van ingegeven kwartaal, hierin zijn

$b$1 : jaar

$b$2 : kwartaal nummer (1-4)

=VERT.ZOEKEN(WEEKDAG(B3;1);Instellingen!$E$5:$F$11;2;ONWAAR)

weekdagnamen, hierin zijn

$E$5:$F$11 :


1 Zo

2 Ma


3 Di

4 Wo


5 Do

6 Vr


7 Za
B3:datum

Datum bepalen aan de hand van jaar en weeknummer (en dag)


=DATE($B$3;1;$G$1*7-2)-WEEKDAY(DATE($B$3;1;3))

$b$3= jaar

$g$1= weeknummer
-2 staat voor maandag

-1 staat voor dinsdag

0 voor woensdag etc
*LAATSTE DAG VAN DE MAAND

Sub GetLastDayOFMonth()

Dim aDate As Date

'Dim lastday As Variant

aDate = CDate(Now())

lastday = Format(DateAdd("d", -1, DateSerial(Year(aDate), Month(aDate), 1)), "DD-MM-YYYY")



'MsgBox Lastday

End Sub



De database wordt beschermd door het auteursrecht ©opleid.info 2019
stuur bericht

    Hoofdpagina