Wikibooks

VBA in Excel/ Weitere unsortierte Beispiele

< VBA in Excel


Belegte Zellen bestimmen Bearbeiten

Mit dem nachfolgenden Beispiel können die erste und letzte belegte Zelle in einer Zeile bestimmt werden. Klicken Sie eine beliebige Zeile an und starten das Makro. Ein Meldungsfenster gibt Ihnen Auskunft, welches die erste und letzte belegte Zelle der angeklickten Zeile ist. 

Sub ErsteUndLetzteBelegteZelleInZeile()
    Dim lngSpalte1&, lngSpalte2 As Long: Dim strAusgabetext As String    
    lngSpalte1 = Cells(ActiveCell.Row, 1).End(xlToRight).Column
    lngSpalte2 = Cells(ActiveCell.Row, Rows(ActiveCell.Row).Cells.Count).End(xlToLeft).Column
    If IsEmpty(Cells(ActiveCell.Row, 1)) = False Then lngSpalte1 = 1    
    strAusgabetext = Switch(lngSpalte1 = Rows(ActiveCell.Row).Cells.Count And lngSpalte2 = 1, _
        "Zeile " & ActiveCell.Row & " ist leer.", lngSpalte1 >= 1 And lngSpalte2 > lngSpalte1, _
        "In der angeklickten Zeile ist die erste belegte Zelle " & Cells(ActiveCell.Row, _
        lngSpalte1).Address(False, False) & vbCr & " mit dem Wert " & _
         Cells(ActiveCell.Row, lngSpalte1) & " und die letzte Zelle ist " & _
        Cells(ActiveCell.Row, lngSpalte2).Address(False, False) & vbCr & " mit dem Wert " & _
        Cells(ActiveCell.Row, lngSpalte2) & ".", lngSpalte1 = lngSpalte2, _
        "Es ist nur Zelle " & Cells(ActiveCell.Row, lngSpalte1).Address(False, False) & _
        " mit dem Wert " & Cells(ActiveCell.Row, lngSpalte1) & " belegt.")        
    MsgBox strAusgabetext, vbInformation
End Sub

Add-Ins Bearbeiten

Add-In installieren 

Sub InstallAddIn()
        Dim AddInNeu As AddIn        
        On Error Resume Next
        Set AddInNeu = AddIns.Add(Filename:=Environ("AppData") & "\Microsoft\AddIns\neuesAddIn.xlam")
        AddInNeu.Installed = True
        MsgBox AddInNeu.Title & " wurde installiert."
        Exit Sub
ErrorHandler:
        MsgBox "An error occurred."
End Sub

Add-In deinstallieren 

Sub AddinEinbinden()
    Application.AddIns("neuesAddIn").Installed = False
End Sub

Add-In schließen 

Sub addInSchließen()
    On Error Resume Next
    Workbooks("neuesAddIn.xlam").Close
End Sub

Variablentyp bestimmen Bearbeiten

Klicken Sie eine belegte Zelle eines Arbeitsblatts an. Mit dem Makro können Sie den Variablentyp einer Zelle bestimmen. 

Sub ZellenWerttypErmitteln()
    Dim strVariablentyp As String
    Dim byteIndex As Byte    
    byteIndex = VarType(ActiveCell)    
    strVariablentyp = Choose(byteIndex + 1, "Empty", "Null", "Integer", "Long", _
        "Single", "Double", "Currency", "Date", "String", "Object", "Error", "Boolean")    
    MsgBox strVariablentyp    
End Sub

Arbeitsblattexistenz bestimmen Bearbeiten

Mit diesem Makro können Sie die Existenz eines Tabellenblatts überprüfen. Wenn Sie in die zweite Inputbox keinen Mappennamen eintragen, wird unterstelltt, dass die Existenz des eingegebenen Tabellenblatts in der aktivierten Mappe geprüft werden soll. (Beachte: der zu überprüfende BlattCodename ist nicht identisch mit dem Tabellennamen (wie auf dem Tabellenregisterblatt). Sie können den jeweiligen BlattCodenamen im Projektexplorer herausfinden. Der Blattcodename ist Tabelle1, Tabelle2 usw.) Verweis: Microsoft Visual Basic for Applications Extensibility 

Function BlattDa(strBlattCodename As String, Optional Mappe As Workbook) As Boolean   
    If Mappe Is Nothing Then
        Set Mappe = ActiveWorkbook
    Else
        For Each Workbook In Application.Workbooks
            If Mappe.Name = Workbook.Name Then Set Mappe = Workbook
        Next Workbook
    End If   
    For Each Worksheet In Mappe.Worksheets
        If Mappe.VBProject.VBComponents(Worksheet.CodeName).Name = strBlattCodename Then
            BlattDa = True
        End If
    Next Worksheet
End Function

Sub CheckForSheet()
    Dim boolBlattDa As Boolean
    Dim strMappenname$
    Dim strBlattCodename$
    strBlattCodename = InputBox("Gebe den Blattcodenamen ein")
    If strBlattCodename = "" Then Exit Sub
    strMappenname = InputBox("Gebe den Namen der geöffneten Mappe ohne Dateiendung ein! " & _
        "Falls Sie nichts eintragen und ok klicken, wird die aktuelle Mappe geprüft!")
    If strMappenname <> "" Then
        On Error Resume Next
        If Workbooks(strMappenname) Is Nothing Then
            MsgBox "Die Mappe ist nicht geöffnet oder existiert nicht", vbCritical
            Exit Sub
        End If
    End If
    If strMappenname = "" Then
        boolBlattDa = BlattDa(strBlattCodename)
    Else
        boolBlattDa = BlattDa(strBlattCodename, Workbooks(strMappenname))
    End If
    If boolBlattDa Then
        MsgBox "Das Blatt existiert!"
    Else
        MsgBox "The worksheet does NOT exist!"
    End If
End Sub

Tabellenlisten mit Anwenderformular editieren Bearbeiten

Erzeugen Sie händisch oder per VBA-Makro eine Tabellenliste und fügen das erste Makro in das Codemodul des verwendeten Arbeitsblatts ein.

Danach erstellen Sie ein Anwenderformular Userform1 und platzieren darauf ein Listenfeld, drei Befehlsschaltflächen Commandbutton1 - 3 und für jede zu editierende Tabellenspalte jeweils ein Texteingabefeld Textbox.

CommandButton1 - Caption: Zeile hinzufügen CommandButton2: Caption: Zeile ändern CommandButton3: Caption: Zeile löschen Um das Makro zu starten, klicken Sie doppelt auf die Tabellenliste.


Codemodul des verwendeten Arbeitsblatts 

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim strListobjectname
    On Error Resume Next
    If Selection.ListObject.Name = "" Then
        MsgBox "Keine Tabellenliste angeklickt"
        Exit Sub
    Else
        strListobjectname = Selection.ListObject.Name
    End If
    Load UserForm1
    With UserForm1
        .Caption = "Verkaufsliste"
        .Show
    End With
End Sub


Codemodul des Anwenderformulars, Name: Userform1 

Private strListobjectname$

Sub ListenfeldFüllen()
    Dim i%, intSpaltenzahl%, sngSpaltenbreite!(), varSpaltenbreiten
    intSpaltenzahl = ActiveSheet.ListObjects(strListobjectname).ListColumns.Count
    For i = 0 To intSpaltenzahl - 1
        ReDim Preserve sngSpaltenbreite(i)
        sngSpaltenbreite(i) = ActiveSheet.ListObjects(strListobjectname).ListColumns(i + 1).Range.ColumnWidth
    Next i
    With Me
        With .ListBox1
                .Clear
                .ListStyle = fmListStylePlain
                .ColumnCount = intSpaltenzahl
                .ColumnHeads = True
                For i = 0 To intSpaltenzahl - 1
                    varSpaltenbreiten = varSpaltenbreiten & CStr(sngSpaltenbreite(i) / 5.3 & " cm;")
                Next i
                .Font.Size = 10.5
                .ColumnWidths = varSpaltenbreiten
                Call RowSourceEinstellen
            End With
        End With
End Sub

Sub RowSourceEinstellen()
    With ListBox1
        .RowSource = ActiveSheet.ListObjects(strListobjectname).Range.Address
        If ActiveSheet.ListObjects(strListobjectname).Range.Rows.Count > 1 Then
            .RowSource = ActiveSheet.ListObjects(strListobjectname).Range.Offset(1, 0).Resize( _
                ActiveSheet.ListObjects(strListobjectname).Range.Rows.Count - 1).Address(External:=True)
        End If
    End With
End Sub

Private Sub CommandButton1_Click()
    Dim Listzeile As ListRow, Bereich As Range, i%, j&, tb As MSForms.Control
    Set Listzeile = ActiveSheet.ListObjects(strListobjectname).ListRows.Add
    Set Bereich = ActiveSheet.ListObjects(strListobjectname).ListRows(Listzeile.Index).Range
    i = 1: j = Listzeile.Index
    For Each tb In Me.Controls
        If TypeName(tb) = "TextBox" Then
            Bereich(i) = tb.Text
            i = i + 1
        End If
    If i > ActiveSheet.ListObjects(strListobjectname).ListColumns.Count Then Exit For
    Next tb
    Call RowSourceEinstellen
    ListBox1.Selected(j - 1) = True
    For Each tb In Me.Controls
        If TypeName(tb) = "TextBox" Then
            tb.Text = ""
        End If
    Next tb
End Sub

Private Sub CommandButton2_Click()
    Dim i%, j&, Bereich As Range, varBereich() As Variant, tb As MSForms.Control
    i = 1
    If ListBox1.ListIndex = -1 Then ListBox1.Selected(0) = True
    j = ListBox1.ListIndex
    On Error Resume Next
    Set Bereich = ActiveSheet.ListObjects(strListobjectname).ListRows(Me.ListBox1.ListIndex + 1).Range
    For Each tb In Me.Controls
        If TypeName(tb) = "TextBox" Then
            ReDim Preserve varBereich(i)
            varBereich(i) = tb.Text
            i = i + 1
        End If
        If i > ActiveSheet.ListObjects(strListobjectname).ListColumns.Count Then Exit For
    Next tb
    For i = 1 To UBound(varBereich)
         Bereich(i) = varBereich(i)
    Next i
    Call RowSourceEinstellen
    ListBox1.Selected(j) = True
    For Each tb In Me.Controls
        If TypeName(tb) = "TextBox" Then
            tb.Text = ""
        End If
    Next tb
End Sub

Private Sub CommandButton3_Click()
    Dim i&, tb As MSForms.Control
    i = ListBox1.ListIndex
    On Error Resume Next
    ActiveSheet.ListObjects(strListobjectname).ListRows(Me.ListBox1.ListIndex + 1).Delete
    Call RowSourceEinstellen
    On Error Resume Next
    ListBox1.Selected(i - 1) = True
    For Each tb In Me.Controls
        If TypeName(tb) = "TextBox" Then
            tb.Text = ""
        End If
    Next tb
End Sub

Private Sub ListBox1_click()
    Dim i%, Bereich As Range, tb As MSForms.Control
    i = 1
    On Error Resume Next
    Set Bereich = ActiveSheet.ListObjects(strListobjectname).ListRows(Me.ListBox1.ListIndex + 1).Range
    For Each tb In Me.Controls
        If TypeName(tb) = "TextBox" Then
            tb.Text = Bereich(i)
            i = i + 1
        End If
        If i > ActiveSheet.ListObjects(strListobjectname).ListColumns.Count Then Exit For
    Next tb
End Sub

Private Sub UserForm_Initialize()
    strListobjectname = Selection.ListObject.Name
    Call ListenfeldFüllen
End Sub


Tabellenlistenzeilen scrollen Bearbeiten

Erzeugen Sie ein Drehfeld und erzeugen per Makro zum Testen eine Tabellenliste. Die letztgenannten Makros kopieren Sie in das Codemodul des verwendeten Arbeitsblatts.


Standardmodul 

Sub SpinbuttonEinfügen()
    Dim cb As OLEObject

    Set cb = ActiveSheet.OLEObjects.Add(ClassType:="Forms.SpinButton.1", Link:=False, _
    DisplayAsIcon:=False, Left:=413.25, Top:=86.25, Width:=28.5, Height:=33)
End Sub

Sub CreateTable()
    [a1] = "Produkt":    [b1] = "Verkäufer": [c1] = "Verkaufsmenge"
    [a2] = "Navigation": [b2] = "Schröder":  [c2] = 1
    [a3] = "Handy":      [b3] = "Schmied":   [c3] = 10
    [a4] = "Navigation": [b4] = "Müller":    [c4] = 20
    [a5] = "Navigation": [b5] = "Schmied":   [c5] = 30
    [a6] = "Handy":      [b6] = "Müller":    [c6] = 40
    [a7] = "iPod":       [b7] = "Schmied":   [c7] = 50
    [a8] = "Navigation": [b8] = "Schröder":  [c8] = 60
    [a9] = "Handy":      [b9] = "Becker":    [c9] = 70
    [a10] = "iPod":     [b10] = "Müller":   [c10] = 80
    On Error Resume Next
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$a$1:$c$10"), , xlYes).Name = _
        "Table1"
    ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight2"
End Sub

Codemodul des Arbeitsblatts mit der Tabellenliste 

Private lo As ListObject, lr As ListRow
Private lngSpinbutton1Max, lngSpinSelected&

Private Sub Worksheet_Activate()
    Call Werte
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call Werte
End Sub

Private Sub SpinButton1_SpinUp()
    Call swap
End Sub

Private Sub SpinButton1_SpinDown()
    Call swap
End Sub

Private Sub Werte()
        If Not Intersect(ActiveCell, ListObjects(1).DataBodyRange) Is Nothing Then
        
        SpinButton1.Max = ActiveSheet.ListObjects(Selection.ListObject.Name).ListRows.Count
        SpinButton1.Min = 1
        lngSpinbutton1Max = SpinButton1.Max
        Set lo = ActiveSheet.ListObjects("Table1")
        For Each lr In lo.ListRows
            If Not Intersect(lr.Range, ActiveCell) Is Nothing Then
                SpinButton1.Value = lngSpinbutton1Max + 1 - lr.Index
                lngSpinSelected = lr.Index
                Exit For
            End If
        Next lr
    End If
End Sub

Private Sub swap()
    Dim lngSpinNeu&
    Dim ZeileNeu As Range, ZeileAlt As Range
    Dim varZeileNeu As Variant, varZeileAlt As Variant, varMerkZeile
    
    On Error Resume Next
    If Not Intersect(ActiveCell, ListObjects(Selection.ListObject.Name).DataBodyRange) Is Nothing Then
       lngSpinNeu = SpinButton1.Max + 1 - SpinButton1.Value
       If lngSpinNeu <> lngSpinSelected Then
            Set ZeileNeu = ActiveSheet.ListObjects(Selection.ListObject.Name).ListRows(lngSpinNeu).Range
            Set ZeileAlt = ActiveSheet.ListObjects(Selection.ListObject.Name).ListRows(lngSpinSelected).Range
            varZeileNeu = ZeileNeu
            varZeileAlt = ZeileAlt
            
            varMerkZeile = varZeileNeu
            varZeileNeu = varZeileAlt
            varZeileAlt = varMerkZeile
            
            ZeileAlt = varZeileAlt
            ZeileNeu = varZeileNeu
            lngSpinSelected = lngSpinNeu
            ActiveSheet.ListObjects(Selection.ListObject.Name).ListRows(lngSpinSelected).Range.Select
            
        End If
    End If
End Sub

Exceldaten in XML-Dokument exportieren Bearbeiten

Soweit mit Ihrer Office-Version XML mitgeliefert wurde, setzen Sie einen Verweis auf Microsoft XML. Dieses Makro verwendet die Version 6.0. Bei Version 5.0 verwenden Sie die Variablendeklaration Domdocument50. 


Sub Excel_XML()
    Dim xml As New MSXML2.domdocument60
    Dim xmlKnoten As MSXML2.IXMLDOMElement
    Dim xmlUnterknoten As MSXML2.IXMLDOMElement
    Dim Zelle As Range, strWert$, strNeu$, i%
    Cells.Clear
    [a1] = "Produkt":    [b1] = "Verkäufer": [c1] = "Verkaufsmenge"
    [a2] = "Navigation": [b2] = "Schröder":  [c2] = 1
    [a3] = "Handy":      [b3] = "Schmied":   [c3] = 10
    [a4] = "Navigation": [b4] = "Müller":    [c4] = 20
    [a5] = "Navigation": [b5] = "Schmied":   [c5] = 30
    [a6] = "Handy":      [b6] = "Müller":    [c6] = 40
    [a7] = "iPod":       [b7] = "Schmied":   [c7] = 50
    [a8] = "Navigation": [b8] = "Schröder":  [c8] = 60
    [a9] = "Handy":      [b9] = "Becker":    [c9] = 70
    [a10] = "iPod":     [b10] = "Müller":   [c10] = 80   
    xml.LoadXML "<?xml version=""1.0"" " & " encoding=""ISO-8859-1""?><meineXMLListe/>"
    For Each Row In [a2:c10].Rows    
        Set xmlKnoten = xml.createElement("Knoten")        
        For Each Zelle In [a1:c1].Columns
            Zelle.Value = Replace(Zelle.Value, "ä", "ae")
            Zelle.Value = Replace(Zelle.Value, "Ä", "Ae")
            Zelle.Value = Replace(Zelle.Value, "ö", "oe")
            Zelle.Value = Replace(Zelle.Value, "Ö", "Oe")
            Zelle.Value = Replace(Zelle.Value, "ü", "ue")
            Zelle.Value = Replace(Zelle.Value, "Ü", "Ue")           
            For i = 1 To Len(Zelle.Value)           
                If Mid(Zelle.Value, i, 1) Like "[a-z]" Or Mid(Zelle.Value, i, 1) Like "[A-Z]" Or _
                    Mid(Zelle.Value, i, 1) Like "[0-9]" Or Mid(Zelle.Value, i, 1) Like "_" Then _
                        strNeu = strNeu & Mid(Zelle.Value, i, 1)
            Next i
            Set xmlUnterknoten = xml.createElement(strNeu)
            xmlKnoten.appendChild(xmlUnterknoten).Text = Cells(Row.Row, Zelle.Column).Value
            strNeu = ""
        Next Zelle
        xml.DocumentElement.appendChild xmlKnoten
    Next Row  
    xml.Save Environ("tmp") & "\meineXMLDatei.xml"
    Set xml = Nothing: Set xmlKnoten = Nothing: Set xmlUnterknoten = Nothing
End Sub

XML-Daten in Excelblatt importieren Bearbeiten

Erzeugen Sie mit dem ersten Makro die Schema-Definition. Der Import erfolgt dann mit dem zweiten Makro, das die Schema-Definition verwendet. 

Sub Create_XSD()
    Dim strMyXml As String, meinMap As XmlMap
    Dim strMeinSchema$
    strMyXml = "<meineXMLListe>" & _
                "<Knoten>" & _
                "<Produkt>Text</Produkt>" & _
                "<Verkaeufer>Text</Verkaeufer>" & _
                "<Verkaufsmenge>999</Verkaufsmenge>" & _
                "</Knoten>" & _
                "<Knoten></Knoten>" & _
                "</meineXMLListe>"
    Application.DisplayAlerts = False
    Set meinMap = ThisWorkbook.XmlMaps.Add(strMyXml)
    Application.DisplayAlerts = True
    strMeinSchema = meinMap.Schemas(1).xml
    Open ThisWorkbook.Path & "\strMeinSchema.xsd" For Output As #1
    Print #1, strMeinSchema
    Close #1
End Sub

Sub CreateXMLList()
    Dim Map1 As XmlMap
    Dim objList As ListObject
    Dim objColumn As ListColumn
    Dim i%    
    If Dir(ThisWorkbook.Path & "\strMeinSchema.xsd") = "" Then Exit Sub
    Set Map1 = ThisWorkbook.XmlMaps.Add(ThisWorkbook.Path & "\strMeinSchema.xsd")   
    On Error Resume Next
    ActiveSheet.ListObjects(1).Delete
    Application.DisplayAlerts = False
    ActiveSheet.Range("A1").Select
    Set objList = ActiveSheet.ListObjects.Add
    objList.ListColumns(1).XPath.SetValue Map1, "/meineXMLListe/Knoten/Produkt"   
    Set objColumn = objList.ListColumns.Add
    objColumn.XPath.SetValue Map1, "/meineXMLListe/Knoten/Verkaeufer"    
    Set objColumn = objList.ListColumns.Add
    objColumn.XPath.SetValue Map1, "/meineXMLListe/Knoten/Verkaufsmenge"   
    objList.ListColumns(1).Name = "Produkt"
    objList.ListColumns(2).Name = "Verkäufer"
    objList.ListColumns(3).Name = "Verkaufsmenge"
    Columns.AutoFit
    Application.DisplayAlerts = False   
    Map1.Import (Environ("tmp") & "\meineXMLDatei.xml")
End Sub

oder:

Standardmodul 

Public Sub GetOverwrite()
    Dim clsOverwrite As New Klasse1
    Cells.Clear

    On Error Resume Next
    clsOverwrite.GetXMLData
End Sub

Klassenmodul, Name: Klasse1 

Public Function GetXMLData() As Variant
    Dim strXmlQuelldatei$
    Dim XmlImportResult As XlXmlImportResult
    
    strXmlQuelldatei = Environ("tmp") & "\meineXMLDatei.xml"
    
    If Dir(strXmlQuelldatei) = vbNullString Then MsgBox "Die Quelldatei wurde nicht gefunden"
    
    XmlImportResult = ActiveWorkbook.XmlImport(strXmlQuelldatei, Nothing, _
         True, ActiveCell)
    If XmlImportResult = xlXmlImportSuccess Then MsgBox "XML Datenimport komplett"
End Function

Exceldaten in Access-Datenbank exportieren Bearbeiten 

Sub neueDatenbankErzeugen()   
    Dim cat As New ADOX.Catalog
    Dim tbl As New ADOX.Table
    Dim strPfad$
    strPfad = Environ("localAPPDATA") & "\microsoft\office\pivotTabelle.accdb"
    If Dir(strPfad) = "" Then _
        cat.Create "Provider = microsoft.ace.oledb.12.0; data source=" & strPfad    
    With tbl
        .ParentCatalog = cat
        .Name = "Früchteverkauf"        
        With .Columns
            .Append "Frucht", adVarWChar, 60
            .Append "Monat", adVarWChar, 10
            .Append "Menge", adInteger
        End With        
        .Columns("Menge").Properties("Nullable") = True
    End With    
    cat.Tables.Append tbl       
    Set tbl = Nothing
    Set cat = Nothing
End Sub

Sub DatenHinzufügenADO()
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim Row As Range, Column As Range
    Dim strPfad$    
    strPfad = Environ("localAPPDATA") & "\microsoft\office\pivotTabelle.accdb"    
    If Dir(strPfad) = "" Then Exit Sub    
    With ActiveSheet        
        .Cells.Clear
        .[a1] = "Frucht":    .[B1] = "Jan.":  .[C1] = "Feb.":  .[D1] = "Mär."
        .[A2] = "Äpfel":     .[B2] = 5:       .[C2] = 3:       .[D2] = 4
        .[a3] = "Orangen":   .[B3] = 4:                        .[D3] = 5
        .[A4] = "Birnen":    .[B4] = 2:       .[C4] = 3:       .[D4] = 5  
        conn.Open "Provider=Microsoft.ace.OLEDB.12.0;" & _
              "Data Source=" & strPfad
    End With   
    With rs
        .Open "Früchteverkauf", conn, adOpenKeyset, adLockOptimistic       
        For Each Row In ActiveSheet.[2:4].Rows
            For Each Column In ActiveSheet.[b:d].Columns
                .AddNew
                !Frucht = ActiveSheet.Cells(Row.Row, 1)
                !Monat = ActiveSheet.Cells(1, Column.Column)
                !Menge = ActiveSheet.Cells(Row.Row, Column.Column)
                .Update
            Next Column
        Next Row       
        .Close
    End With
    Set rs = Nothing: Set conn = Nothing    
End Sub

Pivottabelle aus Accessdatenbank erstellen Bearbeiten 

Sub CreatePivotTableADO()
    Dim PivotC As PivotCache
    Dim PivotT As PivotTable
    Dim strSQL$
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset   
    conn.Open "Provider=Microsoft.ace.OLEDB.12.0;" & "Data Source=" & _
        Environ("localAPPDATA") & "\microsoft\office\pivotTabelle.accdb"   
    rs.Open "Früchteverkauf", conn, adOpenKeyset, adLockOptimistic  
    If rs.RecordCount = 0 Then MsgBox ("Keine Datensätze gefunden!"), vbCritical        
    ActiveWindow.DisplayGridlines = False    
    Set PivotC = ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal)
    Set PivotC.Recordset = rs    
    Worksheets.Add Before:=Sheets(1)    
        Set PivotT = ActiveSheet.PivotTables.Add(PivotCache:=PivotC, _
                TableDestination:=ActiveSheet.Range("a3"))        
    With PivotT
        .NullString = "0"
        .AddFields RowFields:="Frucht", ColumnFields:="Monat"
        .PivotFields("Menge").Orientation = xlDataField
    End With
    Set rs = Nothing
    Set conn = Nothing
    Set PivotT = Nothing
    Set PivotC = Nothing
End Sub


Formula Array Bearbeiten

Wechseln im Menü Excel-Option/ Formeln zum S1Z1-Bezugsstil.

Das Makro erzeugt für einen Test eine Tabellenliste. Geben Sie in die Inputboxen einen Verkäufernamen und einen Produktnamen ein. Als Ergebnis erhalten Sie zunächst eine Information, welche Gesamtmenge des Produkts der Verkäufer insgesamt veräußert hat. Darüber hinaus wird Auskunft gegeben, um wieviele Tabellenpositionen es geht. Geben Sie für einen Test den Verkäufernamen Schröder und den Produktnamen Navigation ein! 

Sub testMich()
    Dim strProdukt$
    Dim strVerkäufer
    Dim strSpalte1
    Dim strSpalte2
    Dim strSpalte3
    Dim Bereich1 As Range
    Dim Bereich2 As Range
    Dim Zelle As Range
    Dim bool As Boolean    
    With ActiveSheet
        .Cells.Clear
        .ListObjects.Add(xlSrcRange, Range("$a$1:$c$10"), , xlYes).Name = "Table1"
        .ListObjects("Table1").TableStyle = "TableStyleLight2"    
        .[a1] = "Produkt":       .[b1] = "Verkäufer":     .[c1] = "Verkaufsmenge"
        .[a2] = "Navigation":    .[b2] = "Schröder":      .[c2] = 1
        .[a3] = "Handy":         .[b3] = "Schmied":       .[c3] = 10
        .[a4] = "Navigation":    .[b4] = "Müller":        .[c4] = 20
        .[a5] = "Navigation":    .[b5] = "Schmied":       .[c5] = 30
        .[a6] = "Handy":         .[b6] = "Müller":        .[c6] = 40
        .[a7] = "iPod":          .[b7] = "Schmied":       .[c7] = 50
        .[a8] = "Navigation":    .[b8] = "Schröder":      .[c8] = 60
        .[a9] = "Handy":         .[b9] = "Becker":        .[c9] = 70
        .[a10] = "iPod":         .[b10] = "Müller":       .[c10] = 80    
        strSpalte1 = ActiveSheet.ListObjects("Table1").DataBodyRange.Columns(1).Address(False, False)
        strSpalte2 = ActiveSheet.ListObjects("Table1").DataBodyRange.Columns(2).Address(False, False)
        strSpalte3 = ActiveSheet.ListObjects("Table1").DataBodyRange.Columns(3).Address(False, False)        
        Set Bereich1 = Range(strSpalte1)
        Set Bereich2 = Range(strSpalte2)        
        strProdukt = InputBox("Gebe das Produkt ein!")
        If strProdukt = "" Then Exit Sub        
        For Each Zelle In Bereich1
            If Zelle.Value = strProdukt Then bool = True
        Next Zelle
        If bool = False Then
            MsgBox "Der eingegebene Produktname existiert nicht oder ist falsch", vbInformation
            Exit Sub
        End If
        bool = False        
        strVerkäufer = InputBox("Gebe den Verkäufer ein!")
        If strVerkäufer = "" Then Exit Sub       
        For Each Zelle In Bereich2
            If Zelle.Value = strVerkäufer Then bool = True
        Next Zelle
        If bool = False Then
            MsgBox "Der eingegebene Verkäufername existiert nicht oder ist falsch", vbInformation
            Exit Sub
        End If       
        .[e9] = "Gesamte Verkaufsmenge " & strProdukt & " durch Verkäufer " & strVerkäufer
        .[e10].FormulaArray = "=SUM((" & strSpalte1 & "= """ & strProdukt & """)*(" & strSpalte2 & "=""" & strVerkäufer & """)*(" & strSpalte3 & "))"        
        .[e12] = "Anzahl der Verkaufspositionen des Produkts " & strProdukt & " duch den Verkäufer " & strVerkäufer  'logischen UND letztlich aber ANZAHL der Zeilen mit Navigation von Schröder ---works---
        .[e13].FormulaArray = "=SUM((" & strSpalte1 & "= """ & strProdukt & """)*(" & strSpalte2 & " = """ & strVerkäufer & """))"       
        End With
End Sub


Bedingte Formatierung Bearbeiten

Dieses Beispiel erzeugt anhand einer Beispieltabelle mit bedingter Formatierung Richtungspfeile, die abhängig vom Trend in eine bestimmte Richtung zeigen. 

Sub SetConditionalFormatting()
    Dim cfIconSet As IconSetCondition: Dim Bool As Boolean
    For Each Worksheet In ThisWorkbook.Worksheets
        If Worksheet.Name = "Bedingte Formatierung" Then Bool = True
    Next Worksheet
    If Bool = False Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Bedingte Formatierung"    
    With Sheets("Bedingte Formatierung")
        .Cells.Clear
        .Range("C1").Value = -0.01:     .Range("C6").Value = 0
        .Range("C2").Value = 0.005:     .Range("C7").Value = 0
        .Range("C3").Value = -0.02:     .Range("C8").Value = 0.005
        .Range("C4").Value = -0.02:     .Range("C9").Value = -0.02
        .Range("C5").Value = 0.005:     .Range("C10").Value = 0.005
        .Range("C1", "C10").NumberFormat = " 0.00 ;[Red] - 0.00 "   
        Set cfIconSet = .Range("C1", "C10").FormatConditions.AddIconSetCondition     
        .Range("C1", "C10").FormatConditions(1).SetFirstPriority
    End With    
    cfIconSet.IconSet = ActiveWorkbook.IconSets(xl3Arrows)
    With cfIconSet.IconCriteria(2)
        .Type = xlConditionValueNumber
        .Value = 0
        .Operator = 7
    End With   
    With cfIconSet.IconCriteria(3)
        .Type = xlConditionValueNumber
        .Value = 0.0001
        .Operator = 7
    End With  
    Set cfIconSet = Nothing
End Sub

Zellengroße Diagramme in Arbeitsblatt einfügen Bearbeiten

Dieses Beispiel erzeugt anhand einiger Testdaten zellengroße Säulendiagramme. 

Sub addTinyCharts()
    Dim Bereich As Range
    Dim i As Integer    
        With ActiveSheet        
            Set Bereich = .[b2:m4]           
            For i = .ChartObjects.Count To 1 Step -1
                    .ChartObjects(i).Delete
            Next i            
            .[a1] = "Frucht":       .[B1] = "Jan.":     .[C1] = "Feb.":  .[D1] = "Mär.":    .[E1] = "Apr.":     .[f1] = "Mai": .[g1] = "Jun.": .[h1] = "Jul.": .[i1] = "Aug.": .[j1] = "Sep.": .[k1] = "Okt.": .[l1] = "Nov.": .[m1] = "Dez.": .[n1] = "Gesamt"
            .[A2] = "Ananas":       .[B2] = 5:          .[C2] = 3:       .[D2] = 4:         .[e2] = 4:          .[f2] = 4:     .[g2] = 4:      .[h2] = 4:      .[i2] = 4:      .[j2] = 4:      .[k2] = 4:      .[l2] = 4:      .[m2] = 4
            .[a3] = "Kiwi":         .[B3] = 45:         .[C3] = 78:      .[D3] = 78:        .[e3] = 78:         .[f3] = 98:    .[g3] = 88:      [h3] = 4:      .[i3] = 4:      .[j3] = 4:      .[k3] = 8:      .[l3] = 69:     .[m3] = 96
            .[A4] = "Papaya":       .[B4] = 54:         .[C4] = 27:      .[D4] = 33:        .[e4] = 82:         .[f4] = 4:     .[g4] = 4:      .[h4] = 4:      .[i4] = 4:      .[j4] = 51:     .[k4] = 10:     .[l4] = 4:      .[m4] = 10
            .[n2].Formula = "=Sum(b2:m2)"
            .[n2].AutoFill .Range("n2:n4"), xlFillDefault
        End With    
    For Each Row In Bereich.Rows        
        ActiveSheet.Shapes.AddChart.Select       
        With ActiveChart
            .ChartType = xlColumnClustered
            .SetSourceData Source:=Row
            .HasLegend = False
            .HasTitle = False
            .Axes(xlCategory, xlPrimary).HasTitle = False
            .Axes(xlValue, xlPrimary).HasTitle = False
            .HasAxis(xlCategory, xlPrimary) = False
            .HasAxis(xlValue, xlPrimary) = False
            .Axes(xlValue).MajorGridlines.Delete
            .Axes(xlValue).MinorGridlines.Delete
            .Axes(xlCategory).MajorGridlines.Delete
            .Axes(xlCategory).MinorGridlines.Delete
            .SeriesCollection(1).Interior.ColorIndex = 37
            .SeriesCollection(1).Border.ColorIndex = 25
            .Parent.Top = ActiveSheet.Cells(Row.Row, 15).Top + 1
            .Parent.Left = ActiveSheet.Cells(Row.Row, 15).Left + 1
            .Parent.Height = ActiveSheet.Cells(Row.Row, 15).Height - 2
            .Parent.Width = ActiveSheet.Cells(Row.Row, 15).Width - 2
            .Parent.Border.ColorIndex = xlNone
            .PlotArea.Top = 0
            .PlotArea.Left = 0
            .PlotArea.Height = .Parent.Height
            .PlotArea.Width = .Parent.Width
            .ChartGroups(1).GapWidth = 50
         End With         
    Next Row
End Sub


Datensatzkollektion anlegen Bearbeiten

Datensätze lassen sich in Datenfelder (Arrays) kopieren. Allerdings ist dann eine flexible Handhabung der Datensätze kaum möglich. Insofern besteht die bessere Alternative, mit Klassenmodulen zu arbeiten und Kollektionen anzulegen.

Beachte: Kopieren Sie die letzten beiden Makros nicht in ein Standard- sondern in ein Klassenmodul. Benennen Sie die im Beispiel genannten Klassenmodule jeweils im Eigenschaftenfenster mit clsKontakt und clsKontakte.

Folgendes Makro wäre möglich: 

Option Base 1
Type Anwenderkontaktdaten
    LfdNr As String
    Nachname As String * 25
    HerrFrau As Boolean
    Fon As String * 25
End Type

Sub ArrayFüllen()
    Dim PersAngaben() As Anwenderkontaktdaten
    Dim i As Integer   
    [a1] = "Lfdnr": [b1] = "Nachname": [c1] = "HerrFrau": [d1] = "Fon"
    [a2] = "1":     [b2] = "Becker":   [c2] = "False":    [d2] = "123"
    [a3] = "2":     [b3] = "Becher":   [c3] = "True":     [d3] = "234"
    [a4] = "3":     [b4] = "Bäcker":   [c4] = "0":        [d4] = "456"
    For i = 2 To ActiveSheet.UsedRange.Rows.Count
        ReDim Preserve PersAngaben(i)        
        PersAngaben(i).LfdNr = Cells(i, 1)
        PersAngaben(i).Nachname = Cells(i, 2)
        PersAngaben(i).HerrFrau = Cells(i, 3)
        PersAngaben(i).Fon = Cells(i, 4)    
    Next i    
    MsgBox "Funktionstest: Im ersten Datensatz " & _
    "steht der Wert " & PersAngaben(2).LfdNr, vbInformation
End Sub

Besser ist folgende Variante:

Standardmodul: 

option explicit
Sub TestKontakteClass()
    Dim Kontakt As clsKontakt
    Dim Kontakte As New clsKontakte
    Dim i As Integer   
    [a1] = "Lfdnr": [b1] = "Nachname":  [c1] = "HerrFrau": [d1] = "Fon"
    [a2] = "1":     [b2] = "Becker":    [c2] = "False":    [d2] = "123"
    [a3] = "2":     [b3] = "Becher":    [c3] = "True":     [d3] = "234"
    [a4] = "3":     [b4] = "Bäcker":    [c4] = "0":        [d4] = "456"
    For i = 2 To ActiveSheet.[a1].CurrentRegion.Rows.Count
        Set Kontakt = New clsKontakt        
        Kontakt.LfdNr = ActiveSheet.Cells(i, 1)
        Kontakt.Nachname = ActiveSheet.Cells(i, 2)
        Kontakt.HerrFrau = CBool(ActiveSheet.Cells(i, 3))
        Kontakt.Fon = ActiveSheet.Cells(i, 4)        
        Kontakte.Add Kontakt
    Next i
    Kontakte.Remove 2  
    MsgBox "Nachdem der Kontakt Nr. 2 gelöscht wurde," & _
    "beträgt die Anzahl der Kontakte " & Kontakte.Count & "." & vbCr & _
    "Jetzt hat der zweite Kontakt die laufende Nummer " & Kontakte.Item(2).LfdNr & "."       
    Set Kontakte = Nothing
End Sub


Klassenmodul, Name: "clsKontakt" 

Option Explicit
Dim pLfdNr As String
Dim pNachname As String
Dim pHerrFrau As Boolean
Dim pFon As String
Public KontaktID As String

Public Property Get LfdNr() As String
    LfdNr = pLfdNr
End Property

Public Property Let LfdNr(strLfdNr As String)
    pLfdNr = strLfdNr
End Property

Public Property Get Nachname() As String
    Nachname = pNachname
End Property

Public Property Let Nachname(strNachname As String)
    pNachname = strNachname
End Property

Public Property Get HerrFrau() As Boolean
    HerrFrau = pHerrFrau
End Property

Public Property Let HerrFrau(boolHerrFrau As Boolean)
    pHerrFrau = boolHerrFrau
End Property

Public Property Get Fon() As String
    Fon = pFon
End Property

Public Property Let Fon(strFon As String)
    pFon = strFon
End Property


Klassenmodul, Name: "clsKontakte" 

Option Explicit
Private KontakteP As Collection

Public Property Get Count() As Long
    Count = KontakteP.Count
End Property

Public Function Item(Index As Variant) As clsKontakt
     Set Item = KontakteP(Index)
End Function

Public Sub Add(Kontakt As clsKontakt)
    On Error GoTo AddError
    KontakteP.Add Kontakt
    Exit Sub
AddError:
    Err.Raise Number:=vbObjectError + 514, Source:="clsKontakte.Add", _
        Description:="Unable to Add clsKontakt object to the collection"
End Sub

Public Sub Remove(ByVal Index As Integer)
    On Error GoTo RemoveError
    KontakteP.Remove Index
    Exit Sub
RemoveError:
    Err.Raise Number:=vbObjectError + 515, Source:="clsKontakte.Remove", _
        Description:="Das clsCell object kann nicht von der Kollektion gelöscht werden!"
End Sub

Private Sub Class_Initialize()
    Set KontakteP = New Collection
End Sub

Private Sub Class_Terminate()
    Set KontakteP = Nothing
End Sub
Abgerufen von „https://de.wikibooks.org/w/index.php?title=VBA_in_Excel/_Weitere_unsortierte_Beispiele&oldid=653315“