Rheinwerk Computing :: Excel 2007 - Das umfassende Handbuch – 23.6 Musterprozeduren für Standardaufgaben

23.6 Musterprozeduren für Standardaufgaben

In diesem Abschnitt ist eine Reihe von Prozeduren zu häufig vorkommenden Aufgaben zusammengestellt, die Sie für eigene Entwicklungen auswerten können.

23.6.1 Prozedur zum Neuformatieren

Wenn Ihnen die Formate in der Titelzeile Ihrer Arbeitsmappen nicht mehr gefallen, hilft ein kleines Makro, Schrift, Schriftfarbe und Zellhintergrund auszutauschen. Das Makro formatiert 25 Zellen der ausgewählten Zeile neu:

Sub titelersetzen() 
 
z = Selection.Row 
s = 1 
 
    For s = 1 To 25 
    Cells(z, s).Select 
    If Selection.Font.Name = "Arial" Then 
       Selection.Font.Name = "Verdana" 
       Selection.Font.ColorIndex = 2 
       Selection.Font.Size = 12 
    End If 
    If Selection.Interior.ColorIndex = 15 Then 
        Selection.Interior.ColorIndex = 16 
    End If 
    Next s 
 
Cells(z, 1).Select 
 
End Sub

23.6.2 Beispiele für Plausibilitätsprüfungen

Vor dem nächsten Schritt in einem Programm, ist es häufig sinnvoll, bestimmte Daten auf Plausibilität zu prüfen.

Hier ein kleines Beispiel, bei dem geprüft wird, ob in einem benannten Bereich überhaupt Werte eingetragen worden sind. Dabei wird die Summenfunktion verwendet:

Set MBereich = Range("Mengen") 
Summe = Application.WorksheetFunction.Sum(MBereich) 
 
If Summe = 0 Then 
        MsgBox ("Keine Positionen eingetragen!") 
        Exit Sub 
End If

23.6.3 Daten aus einem Formular in eine neue Zeile einer Tabelle übernehmen

Die folgenden Codezeilen setzen voraus, dass in einem Bestellformular Daten erfasst worden sind. Die Daten stehen in benannten Zellen und in der Positionszeile. Nun sollen sie an eine Liste der Bestelldaten angehängt werden:

Application.ScreenUpdating = False 
 
    ' Bestelldaten in Bestell-Liste übertragen 
    Sheets("BestellListe").Select 
    zeindex = 24 
 
    Do 
        Do While Worksheets("Bestellformular")._ 
                                           Cells(zeindex, 1) = "" 
        zeindex = zeindex + 1 
        Loop 
        If zeindex > 49 Then Exit Do 
 
        bestelldaten(1) = Range("Belegnummer") 
        bestelldaten(2) = Worksheets("Bestellformular")._ 
                                           Cells(zeindex, 2) 
        bestelldaten(3) = Worksheets("Bestellformular").- 
                                           Cells(zeindex, 3) 
        bestelldaten(4) = Worksheets("Bestellformular")._ 
                                           Cells(zeindex, 5) 
        bestelldaten(5) = Worksheets("Bestellformular")._ 
                                           Cells(zeindex, 6) 
        bestelldaten(6) = Worksheets("Bestellformular")._ 
                                           Cells(zeindex, 8) 
        bestelldaten(7) = Range("Liefnr") 
        bestelldaten(8) = Range("LiefName") 
        bestelldaten(9) = Range("Belegdatum") 
        bestelldaten(10) = Range("LiefTermin")

An dieser Stelle wird die erste freie Zeile in der Tabelle gesucht:

    If Range("A5") <> "" Then 
        Range("A4").End(xlDown).Select 
        ActiveCell.Offset(1, 0).Select 
    Else 
        Range("A5").Select 
    End If

Hier werden die Daten aus den Variablen in die neue Zeile der Tabelle übertragen:

    For i = 1 To 10 
        ActiveCell.Offset(0, i – 1).Value = bestelldaten(i) 
 
    Next i 
    zeindex = zeindex + 1 
 
    Loop 
 
   ' Belegnummer höher setzen und Bereiche löschen

Das Formular wird für die nächste Bestellung bereitgemacht:

    Sheets("Bestellformular").Select 
    ActiveSheet.Unprotect 
 
    Range("AktBelegnr").Value = Range("AktBelegnr").Value + 1 
    Range("LiefTermin").ClearContents 
    Range("Artikelnummern").ClearContents 
    Range("Mengen").ClearContents 
    Range("LiefNR").ClearContents 
    Range("Sachbearbeiter").ClearContents 
    Range("Versandart").ClearContents 
    Range("Bemerkung").ClearContents

23.6.4 Lesen von Daten aus einer Textdatei

Auch ein Makro kann Daten aus einer Textdatei in ein Tabellenblatt einlesen. Verwendet werden dazu »alte« Basic-Befehle. Hier ein Beispiel, bei dem Firmendaten auf ein verstecktes Blatt übernommen werden. Die Textdatei enthält einen Feldnamen und einen Wert für das Feld. Die Zelle, in der der Wert abgelegt wird, wird mit dem betreffenden Feldnamen benannt:

Sub firmendaten_uebernehmen() 
 
    Dim FDatName ' Declare variables. 
    Dim FeldName() 
    Dim FeldWert() 
    i = 1 
    ReDim Preserve FeldName(i) 
    ReDim Preserve FeldWert(i)

Da der Zugriff auf die externe Datei auch scheitern kann, ist hier eine Fehlerbehandlung aktiviert:

   On Error GoTo errormessage 
   Application.ScreenUpdating = False 
 
    Sheets("Firmendaten").Visible = True 
    Sheets("Firmendaten").Select 
 
    FDatName = "Firma.txt” 
 
    Open FDatName For Input As #1 
 
    Line Input #1, FNamen ' Zeile in Variable einlesen. 
    Line Input #1, FWerte 
    Close #1    ' Datei schließen. 
 
    'Feldnamen und -werte auslesen 
 
    f = 1 
    w = 1 
    fpos = InStr(f, FNamen, trennzeichen) 
    wpos = InStr(w, FWerte, trennzeichen) 
 
    Do While fpos > 0 
      FeldName(i) = Mid$(FNamen, f, fpos – f) 
      FeldWert(i) = Mid$(FWerte, w, wpos – w) 
      i = i + 1 
      ReDim Preserve FeldName(i) 
      ReDim Preserve FeldWert(i) 
      f = fpos + 1 
      w = wpos + 1 
      fpos = InStr(f, FNamen, trennzeichen) 
      wpos = InStr(w, FWerte, trennzeichen) 
    Loop 
 
    FeldName(i) = Right$(FNamen, Len(FNamen) – f + 1) 
    FeldWert(i) = Right$(FWerte, Len(FWerte) – w + 1) 
    LetztIn = i 
 
    ' Feldnamen und Feldwerte auf Firmenblatt schreiben 
 
    izeile = 2 
    ispalte = 1 
 
    For i = 1 To LetztIn 
 
         Cells(izeile, ispalte).Value = FeldName(i) 
         Cells(izeile, ispalte + 1).Select 
         ActiveWorkbook.Names.Add Name:=FeldName(i), _ 
                                         RefersToR1C1:=Selection 
         Selection.Value = FeldWert(i) 
         izeile = izeile + 1 
 
    Next i 
   Application.ScreenUpdating = True 
   Exit Sub 
 
errormessage: 
 
    Fehler = Err.Description 
    MsgBox Fehler 
 
End Sub

23.6.5 Einen Bereich neu definieren

Häufig ist es bei der Ausführung eines Makros notwendig, einen Tabellenbereich neu zu definieren. Hier ein einfaches Verfahren, das voraussetzt, dass der Bereich keine Leerzeilen enthalten kann:

Sub kundenbereichneu() 
 
    Range("A4").Select 
    ActiveCell.CurrentRegion.Select 
    Selection.Name = "Kunden" 
 
End Sub

23.6.6 Einen Wert in einer Spalte finden und ersetzen

Mit den folgenden Anweisungen können Sie in einer Kundenliste in der betreffenden Spalte den Namen des Kunden suchen und dann in der dafür vorgesehenen Spalte den Wert für den aufgelaufenen Umsatz ändern.

    Sheets("Kundenliste").Select 
    Set zelle = Range("Kunden").Columns(1).Find(kundenname, _ 
                                               LookIn:=xlValues) 
    zelle.Select 
    ActiveCell.Offset(0, 9).Value = ActiveCell.Offset(0, 9) _ 
                                                    + rechbetrag

23.6.7 In einer Liste von Arbeitsmappen Werte einfügen

Wenn Sie in einer Gruppe von Arbeitsmappen bestimmte benannte Werte einheitlich ändern oder etwa immer in der ersten Zeile eine bestimmte Beschriftung eintragen wollen, können Sie ein Makro schreiben, das dies erledigt. Kopieren Sie die Mappen in einen temporären Ordner, damit die Originaldateien zunächst unberührt bleiben.

Das Makro arbeitet dann alle Mappen in diesem Ordner nacheinander ab.

Sub Datenaustausch() 
    Dim f As String 
 
‘ Ausschalten von automatisch startenden Makros 
    Application.EnableEvents = False 
 
    Application.ScreenUpdating = False 
 
    f = Dir("C:\temp\*.xlsx") 
    Do Until f = "" 
        Workbooks.Open "C:\temp\" & f 
        MsgBox f 
 
        Range("MWST").Value = 16% 
        ActiveWorkbook.Save 
        ActiveWorkbook.Close 
        f = Dir() 
    Loop 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
 
End Sub

Ihre Meinung

Wie hat Ihnen das Openbook gefallen? Wir freuen uns immer über Ihre Rückmeldung. Schreiben Sie uns gerne Ihr Feedback als E-Mail an kommunikation@rheinwerk-verlag.de.