Excel VBA



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= " & periodev & " and periode 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)=1));"giro"; ALS(OF(LENGTE(A1)>9;OF(LENGTE(A1) ................
................

In order to avoid copyright disputes, this page is only a partial summary.

Google Online Preview   Download