Excel VBA tips & trucs (28-1-2010)

Vragen beantwoord ik tegen betaling van een uurtarief van € 60,- met een minimum van 1 uur

I N H O U D S O P G A V E

1 Automatisch aanpassen bereik draaitabellen

1.1 Instructie:

2 Automatisch werkbladen maken en van naam voorzien .

3 Tabel uit Access inlezen in Excel

4 Rijen om en om kleuren

5 Functie om Nederlandse weeknummer af te leiden .

6 Functie om burgerservicenummer te toetsen

7 Functie om nummer naar kolomnaam om te zetten .

8 Functie om de leeftijd te berekenen

• Automatisch aanpassen bereik draaitabellen

Onderstaande code werkt automatisch alle bereiken bij van alle draaitabellen in een werkmap

• Instructie:

• Open het excel sheet met de draaitabel(len)

• Druk op [ALT] en tik op [F11]

Het volgende scherm verschijnt:

Druk op de aangewezen knop

Kies module
Plak onderstaande code daarin

Code :

Sub AdjustRangesPivotTables()

‘ past bereik aan voor alle draaitabellen gebaseerd op verschillende bereiken

‘© H. de Walle; www.walmar.nl

Dim pt As PivotTable

Dim sht As Worksheet

Dim sheetNr As Integer

Dim goal, target, inputformula As String

For Each sht In Worksheets

For Each pt In sht.PivotTables

sheetNr = Replace(Left(pt.SourceData, InStr(pt.SourceData, “!”) – 1), “'”, “”)

goal = Replace(Mid(pt.SourceData, InStr(pt.SourceData, “!”) + 1, InStrRev(pt.SourceData, “:”) – InStr(pt.SourceData, “!”) – 1), “K”, “C”)

inputformula = “=” & goal

target = Application.ConvertFormula( _

Formula:=inputformula, _

fromReferenceStyle:=xlR1C1, _

toReferenceStyle:=xlA1)

pt.SourceData = Sheets(sheetNr).Range(target).CurrentRegion.Address(True, True, xlR1C1, True)

End Sub

Sla de boel op
Sluit af via kruisje rechts bovenin

Je komt dan terug in Excel.

Je kunt dan via Extra->Macro-<Macro's … de Macro uitvoeren

Je kunt de macro ook aan een knop koppelen:

Klik met de rechter muisknop ergens op een werkbalk
Kies aanpassen

Kies links voor: Macro's
Sleep het lachebekje naar een van de werkbalken

Klik met de rechter muisknop op het lachebekje
Kies Macro toewijzen

Kies de macro
Sluit de hele boel

En voortaan hoef je alleen nog op het lachebekje te klikken en de bereiken worden aangepast!!

• Automatisch werkbladen maken en van naam voorzien

Deze macro kunnen we het beste plaatsen in de algemene macro map. De macro is dan in elke nieuwe werkmap te gebruiken. Bestaat deze persoonlijke werkmap nog niet, dan moeten we deze maken door eenmalig zelf een macro op te nemen en deze op te slaan in de persoonlijke werkmap.

Sub WerkBladenMakerEnNaamGever()

'© H. de Walle; www.walmar.nl

Dim x As Worksheet

Dim i, j, eindPunt As Integer

Dim naamPje As String

eindPunt = inputbox("tot en met welk getal")

naamPje = inputbox("naam van de werkbladen")

'werkbladen maken

If ActiveWorkbook.Worksheets.Count < eindPunt Then

For i = ActiveWorkbook.Worksheets.Count + 1 To eindPunt

ActiveWorkbook.Worksheets.Add

Next i

End If

'werkbladen benoemen

j = 1

For Each x In ActiveWorkbook.Worksheets

x.Name = naamPje & " " & j

j = j + 1

End Sub

• Tabel uit Access inlezen in Excel

Sub AccessTabelInlezen()

'© H. de Walle; www.walmar.nl

Dim db As Database

Dim rs As Recordset

Dim i As Integer, t As Integer

'access database kiezen

Set db = OpenDatabase("d:\data\northwind.mdb")

'access tabel kiezen

Set rs = db.OpenRecordset("customers")

t = 0

rs.MoveFirst

Range("a1").Select

For i = 0 To rs.Fields.Count - 1

ActiveCell.Offset(0, i).Value = rs.Fields(i).Name

Next i

i = 0

Range("a2").Select

Do While Not rs.EOF

For i = 0 To rs.Fields.Count - 1

ActiveCell.Offset(t, i).Value = rs.Fields(i).Value

Next i

t = t + 1

rs.MoveNext

Loop

rs.Close

'bovenste rij met veldnamen vet maken

Rows("1:1").Select

Selection.Font.Bold = True

'kolommen automatisch op de juiste breedte instellen

Cells.Select

Cells.EntireColumn.AutoFit

Range("A1").Select

End Sub

• Rijen om en om kleuren

Sub RijenOmEnOmKleuren()

Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _

"=REST(RIJ();2)=0"

Selection.FormatConditions(1).Interior.ColorIndex = 34

Selection.Copy

Cells.Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

Range("a1").Select

End Sub

• Functie om Nederlandse weeknummer af te leiden

Function weekNummerNL(datum As Date) As String

'integer als output: geheel getal

'date als input: datum

Dim intWeeknr As Integer

If IsDate(datum) Then

intWeeknr = DatePart("ww", datum, 2, 2)

weekNummerNL = "week " & Right("00" & intWeeknr, 2)

Else

weekNummerNL = "datum is fout"

End If

End Function

• Functie om burgerservicenummer te toetsen

Function BurgerServiceNummer(s As Long) As String

Dim getal As Long

getal = 9 * Mid(s, 1, 1)

getal = getal + 8 * Int(Mid(s, 2, 1))

getal = getal + 7 * Int(Mid(s, 3, 1))

getal = getal + 6 * Int(Mid(s, 4, 1))

getal = getal + 5 * Int(Mid(s, 5, 1))

getal = getal + 4 * Int(Mid(s, 6, 1))

getal = getal + 3 * Int(Mid(s, 7, 1))

getal = getal + 2 * Int(Mid(s, 8, 1))

getal = getal + -1 * Int(Mid(s, 9, 1))

'MsgBox getal

If getal Mod 11 = 0 Then

BurgerServiceNummer = "Correct"

Else

BurgerServiceNummer = "Incorrect"

End If

End Function

• Functie om nummer naar kolomnaam om te zetten

Function nummerNaarKolom(ByVal nummer)

Dim addr As String

If nummer > Cells.Columns.Count Then

nummerNaarKolom = ""

Exit Function

End If

addr = Range("A1").Offset(0, nummer - 1).Address

nummerNaarKolom = Replace(Replace(addr, "$", ""), Range(addr).Row, "")

End Function

• Functie om de leeftijd te berekenen

Function leeftijd(datum)

If Not IsDate(datum) Then

leeftijd = ""

Exit Function

End If

If Month(Date) > Month(datum) Then

leeftijd = Year(Date) - Year(datum)

Else

If Month(Date) < Month(datum) Then

leeftijd = Year(Date) - Year(datum) - 1

Else

If Day(Date) < Day(datum) Then

leeftijd = Year(Date) - Year(datum) - 1

Else

leeftijd = Year(Date) - Year(datum)

End If

End Function