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.
To fulfill the demand for quickly locating and searching documents.
It is intelligent file search solution for home and business.
Related download
- homepage code with vba
- option explicit northern kentucky university
- gpu based gmxbs modeling program fortress technologies
- vba macros for solving problems in water chemistry
- creating and using an array with vba
- this web page contains material for the computing an data
- code numbertect function excel Λύσεις
Related searches
- excel vba userform listbox multiselect
- free excel vba code samples
- excel vba commands
- excel vba code library
- excel vba quick reference pdf
- excel vba listbox multiple selection
- excel vba character code
- excel vba guide pdf
- excel vba reference
- excel vba reference library
- excel vba listbox selected value
- excel vba cheat sheet