Getagged: VBA

BINGO! mit Excel 365
Hey! Alle lieben BINGO, oder?
Und Excel ist auch noch so gut und liest uns alle ca. 20 Sekunden die neuen Zahlen vor!
Zu Nikolaus 2020 habe ich die BINGO-Datei mit Excel 365 erstellt, da mich hier einige Formeln gereitzt haben. Dann noch „ein wenig“ VBA programmiert, damit die zufälligen Zahlen von 1 bis 75 vorgelesen werden, bis jemand den STOPP-Button drückt.
Da ich VBA nutze, funktioniert der Code nicht im Browser.

Die Felder werden zufällig erstellt. Unter dem B nur die Zahlen 1 bis 15, unter dem I entsprechend 16 bis 30, unter dem N 31 bis 45, unter dem G die Zahlen 46 bis 60 und unter dem O die Zahlen 61 bis 75. Jede Zahl natürlich nur einmal. Das mittlere Feld dient als Joker.
Die Seiten sind so vorbereitet, dass man entsprechend die Spielscheine drucken oder als PDF erstellen und an seine online-BINGO-Mitspieler/-innen schicken kann.

Wenn das Spiel nun losgeht, sieht der Spielführer zur Kontrolle auf diesem Blatt auch, welche Zahlen passen und entsprechend fünf Treffer in einer horizontalen, diagonalen oder vertikalen Reihe ergeben.

Hier natürlich nicht Schummeln!
Auf dem anderen Blatt lässt sich dann prüfen, ob ein BINGO oder ein weiteres erzielt wurde.
In der Regel sieht die Spielleitung nur die folgenden drei Schalter.

Mit Spiel neu Starten wird ein Spiel komplett neu begonnen. Wenn jemand BINGO ruft, muss man auf die mittlere Schaltfläche klicken, der Spielverlauf wird dann unterbrochen und kann sofort weitergeführt werden oder erst so lange Warten, bis jemand rechts auf WEITER drückt.
Für das Spiel selbst muss natürlich der Ton eingeschaltet sein, sonst kann Excel ja nichts vorlesen.
Datei zum Download als XLSM-Datei wegen der Programmierung. Bitte nur Herunterladen, wenn ihr fremden VBA-Code ausführen dürft. Vielleicht einfach vorher mit ALT + F11 in den Code hineinschauen.
Videolink zu YouTube: https://youtu.be/gQvdEb24xpM
Hier nur der Code zur Demonstration. Geht bestimmt viel feiner 😉
Solltet ihr noch Fehler finden, korrigiere ich natürlich gerne meine Version.
'### BINGO! von Andreas Thehos, 2020-12-06 ###
'### Läuft wegen einige Funktionen nur unter Excel 365 ###
Global Zahlen(1 To 75, 1 To 2) As String 'In dieses Array werden die Ziehungen gespeichert und die Ausgabezeit vermerkt.
Global Zeit As Date
Global i As Integer
Global Dauer As Integer
Public Sub BINGO_initialize()
Dim z As Integer
Dim NewGame As Integer
Dim WerteGefuellt As Boolean
Dim Bereich As Range
Dim Zelle As Range
Set Bereich = Range("BINGOWerte")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Ziehungen")
Dauer = Range("Dauer").Value
NewGame = MsgBox("Möchtest Du ein neues Spiel starten?", vbYesNo, "Neues Spiel") If NewGame = 7 Then Exit Sub
ws.Columns("Z:AB").Clear
WerteGefüllt = False Do Until WerteGefuellt = True
Application.Calculate
If Range("WerteEinmalig").Value = 1 Then WerteGefuellt = True
Loop z = 1 For Each Zelle In Bereich.Cells
Zahlen(z, 1) = Zelle.Value
z = z + 1
Next
Range("SpielAn") = 1
Zeit = Now + TimeSerial(0, 0, Dauer)
i = 1
BINGO_START (Zeit)
End Sub
Public Sub BINGO_run()
Dim NewGame As Integer
Dim WerteGefuellt As Boolean
Dim Zeit As Date
Dim Bereich As Range
Dim Zelle As Range
Dim Bingo As Integer
Dim ws As Worksheet
Dim Dauer As Integer
Set Bereich = Range("BINGOWerte")
Set ws = ThisWorkbook.Sheets("Ziehungen")
Dauer = Range("Dauer").Value
If Range("SpielAn") = 1 Then
Zeit = Time
Application.Speech.Speak Zahlen(i, 1)
Zahlen(i, 2) = Zeit
ws.Cells(9 + i, 26).Value = Zahlen(i, 1) ws.Cells(9 + i, 27).Value = Zahlen(i, 2) Zeit = Zeit + TimeSerial(0, 0, Dauer) i = i + 1
End If
If i = 76 Then Exit Sub
If Range("SpielAn") = 1 Then
Zeit = Now + TimeSerial(0, 0, Dauer)
BINGO_START (Zeit)
Else
Bingo = MsgBox("BINGO?", vbYesNo, "Unterbrechung")
If Bingo = 6 Then
MsgBox "Das Spiel wird unterbrochen. Herzlichen Glückwunsch! Weiter mit WEITER!", vbOKOnly, "Unterbrechung"
Exit Sub
Else
Range("SpielAn") = 1
Zeit = Now + TimeSerial(0, 0, Int(Dauer / 2))
BINGO_START (Zeit)
End If
End If
End Sub
Sub BINGO_START(Zeit)
Debug.Print Zeit
Application.OnTime Zeit, "Bingo_run"
End Sub
Sub WEITER()
Range("SpielAn") = 1
BINGO_run
End Sub
Sub BingoUnterbrechung()
Range("SpielAn").Value = 0
End Sub
Sub Scheine_generieren()
Dim Scheine As Range
Dim Zielschein As Range
Set Scheine = Range("Scheine")
For Each Zielschein In Scheine.Cells Range("Beispielschein").Copy Range(Zielschein).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Next
End Sub
Viel Spaß und Glück beim BINGO!
Es gibt sicher auch noch einigen Verbesserungsbedarf.
Eine frohe Weihnachtszeit wünscht
Andreas
P.S.: Hey, Jürgen und René! Danke euch von Herzen. Freut mich doch jedes mal, wenn man an einander denkt.
P.P.S.: Meine Amazon-Wunschliste habe ich gelöscht und bin auf https://www.wunschzettel.de/thehos umgestiegen.
Excel – Serienmail mit Anhängen
Serienmails können über Word / Outlook leider nur ohne Anhänge verschickt werden. Warum also nicht die Serienmail über Excel starten und so beliebig Anhänge mitschicken?
Hier ist der Code:
Option Explicit
Sub Excel_Serial_Mail()
‚Andreas Thehos
‚http://thehosblog.com
Dim objOLOutlook As Object
Dim objOLMail As Object
Dim lngMailNr As Long
Dim lngZaehler As Long
Dim strAttachmentPfad1 As String, strAttachmentPfad2 As String
Dim strSignatur As String
On Error GoTo ErrorHandler
Set objOLOutlook = CreateObject(„Outlook.Application“)
lngMailNr = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
’strAttachmentPfad1 = „C:\Users\Andreas\Documents\Spenden Kinder-Tafel.docx“
’strAttachmentPfad2 = „C:\Users\Andreas\Documents\YouTube\YouTube 2.jpg“
‚Hier Pfade und Dateien anpassen
For lngZaehler = 2 To lngMailNr
If Cells(lngZaehler, 1) „“ Then
Set objOLMail = objOLOutlook.CreateItem(olMailItem)
With objOLMail
.To = Cells(lngZaehler, 1)
.CC = „“
.BCC = „“
.GetInspector.Activate
strSignatur = .Body
.Sensitivity = 3
.Importance = 2
.Subject = „Vorgabe Wochenplan“
.BodyFormat = olFormatPlain
.Body = „Hallo “ & Cells(lngZaehler, 3) & „,“ & vbCrLf & _
Cells(lngZaehler, 2).Value & “ ist die Zahl des Tages.“ & vbCrLf & strSignatur
‚Hier anpassen
‚.Attachments.Add strAttachmentPfad1
‚.Attachments.Add strAttachmentPfad2
.Display
.Send
‚.Display
End With
Set objOLMail = Nothing
End If
Next lngZaehler
Set objOLOutlook = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & “ “ & Err.Description & “ “ & Err.Source, _
vbInformation, „Ein Fehler ist aufgetreten“
Exit Sub
End Sub
Hier ist die Datei:
http://1drv.ms/1kgYEx0
Hier geht es zum Video:
Videolink: http://youtu.be/i-gvQQ0749Y
Excel VBA – Dateieigenschaften verändern
Über VBA können die Eigenschaften einer Arbeitsmappe verändert werden. Die Eigenschaften müssen zum Teil manuell gefüllt werden (Firma, Schlüsselwörter, Kategorie), zum Teil setzen diese sich bei der Arbeit mit der Mappe automatisch zusammmen (Author, Erstelldatum).
Die Eigenschaften sind unter Datei – Informationen im rechten Bereich zu finden.
Das folgende Makro listet alle Eigenschaften der ActiveWorkbook.BuiltinDocumentProperties auf:
Sub Liste_der_Eigenschaften()
Dim intWert As Integer
'Quelle: "http://msdn.microsoft.com/de-de/library/office/ff197172(v=office.15).aspx"
intWert = 1
Worksheets(1).Activate
For Each prop In ActiveWorkbook.BuiltinDocumentProperties
Cells(intWert, 1).Value = intWert
Cells(intWert, 2).Value = prop.Name
intWert = intWert + 1
Next
End Sub
Nicht alle Dokumenteigenschaften sind direkt über Datei – Informationen einsehbar. Andere werden errechnet. Folgende Liste resultiert im ersten Tabellenblatt:
1 Title
2 Subject
3 Author
4 Keywords
5 Comments
6 Template
7 Last author
8 Revision number
9 Application name
10 Last print date
11 Creation date
12 Last save time
13 Total editing time
14 Number of pages
15 Number of words
16 Number of characters
17 Security
18 Category
19 Format
20 Manager
21 Company
22 Number of bytes
23 Number of lines
24 Number of paragraphs
25 Number of slides
26 Number of notes
27 Number of hidden Slides
28 Number of multimedia clips
29 Hyperlink base
30 Number of characters (with spaces)
31 Content type
32 Content status
33 Language
34 Document version
Die Zahlen oder die Namen können nun genutzt werden, die Eigenschaften des aktiven Dokuments zu verändern.
Über das folgende Makro setze ich die Dokumenteigenschaften auf von mir vordefinierte Wert:
Sub Eigenschaften_Arbeitsmappe()
'Andreas Thehos, 2013
If Workbooks.Count >= 1 Then 'Prüft, ob mindestens eine Arbeitsmappe vorliegt
With ActiveWorkbook.BuiltinDocumentProperties 'Setzt die Eigenschaften der aktiven Mappe
.Item("Title") = "YouTube-Tutorial athehos"
.Item("Keywords") = "Excel, Office, Thehos, athehos"
.Item("Comments") = "Excel online lernen"
.Item("Category") = "YouTube, Excel, Office, athehos"
.Item("Subject") = "YouTube-Tutorial"
.Item("Hyperlink base") = "http://thehosblog.com"
.Item("Creation date") = Now
.Item("Company") = "at IT-Training & Beratung"
.Item("Manager") = "Andreas Thehos"
.Item("Author") = "Andreas Thehos"
End With
End If
End Sub
Zum YouTube-Video:
Du muss angemeldet sein, um einen Kommentar zu veröffentlichen.