September 2017

VBA-Kracher September 2017

Im September-VBA-Kracher Newsletter werden die folgenden Themen behandelt:

  • Shapes anhand einer Vorgabeliste automatisch anlegen
  • Eine Meldung am Bildschirm anzeigen und automatisch wieder schlie├čen
  • Alle gef├╝llten Zellen in einem benannten Bereich kennzeichnen
  • Eine eigene Zugangskontrolle f├╝r eine Mappe erstellen
  • Alle Dokumentinformationen aus einer Mappe entfernen
  • Eine Tabelle Spalte f├╝r Spalte separat sortieren

Shapes anhand einer Vorgabeliste automatisch anlegen

Bei der ersten Aufgabenstellung sollen Shape-Objekte automatisch in eine Tabelle eingef├╝gt werden. Dazu liegt eine Tabelle mit den folgenden Informationen vor.

Anhand dieser Vorlage sollen jetzt Shape-Objekte (hier Rechtecke) eingef├╝gt werden.

 

 

 

 

 

 

 

 

Mit einem Klick auf das entsprechende Rechteck soll dann die Zuordnung in die aktive Zelle (hier ist es die Zelle E9 geschrieben werden. Das Makro f├╝r die automatische Anlage der klickbaren Oberfl├Ąche sieht dabei wie folgt aus:

Sub ShapeEinfuegenUndBeschriften()
Dim lngSpalte As Long, lngSpalteMax As Long
Dim lngZeile As Long, lngZeileMax As Long
Dim iTop As Integer, Dim iLeft As Integer
Dim VarDat() As Variant
Dim i As Integer, shpG As Shape

With Tabelle1
.DrawingObjects.Delete
lngSpalteMax = .Cells(1, .Columns.Count).End(xlToLeft).Column
iTop = 110
iLeft = 1

For lngSpalte = 1 To lngSpalteMax
Set shp = Tabelle1.Shapes.AddShape(msoShapeRectangle, _
 iLeft = iLeft + 100, 10, 100, 50)
shp.TextFrame.Characters.Text = .Cells(1, lngSpalte).Value
shp.Fill.Visible = msoTrue
shp.Fill.ForeColor.SchemeColor = 4
shp.Line.Visible = msoTrue
shp.Line.ForeColor.SchemeColor = 3
shp.Name = .Cells(1, lngSpalte).Value
shp.OnAction = "Schreiben"
shp.Top = iTop
shp.Left = iLeft
iTop = iTop + 10
i = i + 1
ReDim Preserve VarDat(1 To i)
VarDat(i) = shp.Name

lngZeileMax = .Cells(.Rows.Count, lngSpalte).End(xlUp).Row

For lngZeile = 2 To lngZeileMax

iTop = iTop + 40
Set shp = Tabelle1.Shapes.AddShape(msoShapeRectangle, 10, 10, 50, 50)
shp.TextFrame.Characters.Text = .Cells(lngZeile, lngSpalte).Value
shp.Fill.Visible = msoTrue
shp.Fill.ForeColor.SchemeColor = 8
shp.Line.Visible = msoTrue
shp.Line.ForeColor.SchemeColor = 6
shp.Name = .Cells(1, lngSpalte).Value & " " & .Cells(lngZeile, lngSpalte).Value
shp.OnAction = "Schreiben"
shp.Top = iTop
shp.Left = iLeft
i = i + 1
ReDim Preserve VarDat(1 To i)
VarDat(i) = shp.Name

Next lngZeile

Set shpG = Tabelle1.Shapes.Range(VarDat).Group
shpG.Name = "Shape" & .Cells(1, lngSpalte).Value
Erase VarDat
iTop = 110
iLeft = iLeft + 110

Next lngSpalte

.Range("E8").Select
End With
End Sub

Sub Schreiben()
 ActiveCell.Value = Application.Caller
End Sub

'**** Quelle: VBA-Tanker, ID: 8868

Im ersten Befehl werden zun├Ąchst alle Zeichnungs-Objekte (DrawingObjects) in der Tabelle mit Hilfe der Methode Delete entfernt. Danach wird der Start-Position des ersten Rechtecks in der Tabelle festgelegt. In einer Schleife wird jetzt die Vorgabetabelle Spalte f├╝r Spalte abgearbeitet. Mit Hilfe der Methode AddShape werden die einzelnen Rechtecke nun eingef├╝gt. Dabei wird im ersten Parameter der Methode festgelegt, um welchen Typ eines Zeichnungsobjektes es sich dabei handelt. Des Weiteren wird die genaue Position des Shapes ├╝ber die Parameter Left, Top, Width und Height festgelegt. Die Beschriftung des eingef├╝gten Rechtecks wird jeweils aus den Zellen der Zuordnungstabelle gezogen. Diverse Eigenschaften f├╝r die Optik folgen danach. Die Sitzpl├Ątze pro Tisch werden im Anschluss eingef├╝gt. Dabei werden die einzelnen Shapes in ein Datenfeld eingelesen, um sie am Ende der Makros gruppieren zu k├Ânnen. Hervorheben m├Âchte ich an dieser Stelle den Befehl OnAction. Hier haben Sie die M├Âglichkeit, dem eingef├╝gten Objekt ein Makro zuzuweisen, das dann per Klick ausgef├╝hrt werden soll. ├ťber den Befehl Application.Caller kann ermittelt werden, welches Rechteck angeklickt wurde.

Eine Meldung am Bildschirm anzeigen und automatisch wieder schlie├čen

Beim folgenden Beispiel wird beim ├ľffnen einer Mappe eine Meldung am Bildschirm angezeigt, die dann nach einer Sekunde automatisch wieder geschlossen wird. Eine sogenannte Meldung wird auch als Splash-Screen bezeichnet. Das Makro f├╝r diese Aufgabe wird im Ereignis Workbook_Open Ereignis hinter der Kategorie DieseArbeitsmappe eingef├╝gt.

Private Sub Workbook_Open()
Dim objShell As Object

Set objShell = CreateObject("WScript.Shell")
objShell.Popup "Guten Tag " & Environ("username") & _
vbCrLf & "Aktuelles Datum/Uhrzeit: " & Now, 1, "Titel der Meldung"

Set objShell = Nothing
End Sub

'**** Quelle: VBA-Tanker, ID: 8848

Mit Hilfe der Funktion CreateObject wird ein Verweis auf die Windows-Bibliothek Wscript gelegt. Diese Bibliothek enth├Ąlt unter anderem die Methode PopUp, ├╝ber die eine Meldung am Bildschirm angezeigt werden kann. Dabei k├Ânnen der Titel der Meldung, der eigentliche Inhalt und die Dauer der Anzeige bestimmt werden.

 

 

Alle gef├╝llten Zellen in einem benannten Bereich kennzeichnen

Wie viele Codezeilen braucht man wohl, um diese Aufgabe zu erledigen? Genau eine einzige. Dieser Einzeiler sieht dabei wie folgt aus:

Sub AlleGef├╝lltenZellenImBenanntenBereichKennzeichnen()

Tabelle1.Range("Daten").SpecialCells(xlCellTypeConstants).Interior.ColorIndex = 4

End Sub

'**** Quelle: VBA-Tanker, ID: 8845

Mit Hilfe der Methode SpecialCells und der Konstante xlCellTypeConstants lassen sich alle gef├╝llten Zellen in einem benannten Bereich automatisch ansprechen. ├ťber die Eigenschaft ColorIndex wurden diese Zellen dann eingef├Ąrbt.

 

 

Eine eigene Zugangskontrolle f├╝r eine Mappe erstellen

Im vorliegenden Beispiel muss die Mappe im Verzeichnis c:\Test ablegen, damit diese ge├Âffnet werden kann. Wenn jemand die Makrounterst├╝tzung ausschaltet, dann ist dabei eine zus├Ątzliche Sicherung eingebaut. Beim Schlie├čen der Mappe werden alle Tabellen sicher ausgeblendet bis auf die Tabelle tbl_Error. Beim ├ľffnen der Mappe werden dann alle Tabellen dynamisch eingeblendet (mit Ausnahme der Tabelle tbl_Error und tbl_Pfad). Diese k├Ânnen bei Bedarf ├╝ber das Eigenschaften-Fenster in der Entwicklungsumgebung eingeblendet werden.┬á ├ľffnet jetzt ein Anwender die Mappe bei deaktivierten Makros, dann sieht er nur die Tabelle tbl_Error.

Bei der zweiten Pr├╝fung wird die Zelle B2 in der Tabelle tbl_Pfad mit dem Speicherpfad der Mappe verglichen. Weicht der ab, dann wird die Mappe wieder geschlossen. Somit kann die Mappe nicht gestartet werden, wenn diese in ein anderes Verzeichnis kopiert wird.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wksBlatt As Worksheet

tbl_Error.Visible = xlSheetVisible
For Each wksBlatt In ThisWorkbook.Worksheets
If wksBlatt.CodeName <> "tbl_Error" Then
wksBlatt.Visible = xlSheetVeryHidden
End If
Next wksBlatt
ThisWorkbook.Save
End Sub

Private Sub Workbook_Open()
Dim wksBlatt As Worksheet

For Each wksBlatt In ThisWorkbook.Worksheets
Select Case wksBlatt.CodeName
Case "tbl_Pfad"

Case Else
wksBlatt.Visible = xlSheetVisible
End Select

Next wksBlatt

If tbl_Pfad.Range("B1").Value <> ThisWorkbook.Path Then
MsgBox "Das Tool befindet sich nicht im erwarteteten Verzeichnis! und tsch├╝ss!"
ThisWorkbook.Close savechanges:=True
End If

tbl_Error.Visible = xlSheetVeryHidden
tbl_Start.Select

End Sub

'**** Quelle: VBA-Tanker, ID: 8838

 

Alle Dokumentinformationen aus einer Mappe entfernen

Bei der folgenden L├Âsung werden alle Dokumenteigenschaften aus einer Arbeitsmappe entfernt.

Sub DokumentInformationenEntfernen()

 ActiveWorkbook.RemoveDocumentInformation (xlRDIDocumentProperties)

End Sub

Mit Hilfe der Methode RemoveDocumentInformation lassen sich Informationen wie beispielsweise der Autor der Mappe automatisch entfernen.

 

Eine Tabelle Spalte f├╝r Spalte separat sortieren

Bei dem abschlie├čendem Beispiel in diesem Newsletter stelle ich Ihnen eine Methode vor, wie Sie eine Tabelle Spalte f├╝r Spalte sortieren k├Ânnen. Genau davor warne ich normalerweise meine Schulungsteilnehmer, aber in diesem Beispiel (siehe Bild) wird diese Technik genauso gew├╝nscht.

Das Makro f├╝r das spaltenweise sortieren einer Tabelle sieht wie folgt aus.

Sub SpaltenweiseSortieren()
Dim lngZeileMax As Long
Dim lngSpalteMax As Long
Dim lngSpalte As Long

With Tabelle1
lngZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row
lngSpalteMax = .Cells(1, .Columns.Count).End(xlToLeft).Column

For lngSpalte = 1 To lngSpalteMax
.Range(.Cells(1, lngSpalte), .Cells(lngZeileMax, lngSpalte)).Sort _
key1:=.Cells(1, lngSpalte), order1:=xlAscending, Header:=xlYes
Next lngSpalte

End With

End Sub

'**** Quelle: VBA-Tanker, ID: 8826

Der Trick bei dem spaltenweise sortieren besteht darin, dass der Sortiervorgang in einer Schleife vorgenommen wird. Innerhalb der Schleife wird jeweils nur der Bereich spaltenweise abgegriffen.