Profi-Excel.de » VBA Makros

Kleinanzeigen Suche

Eike — Tue, 22 Mar 2011 21:55:57 +0000

Das Beispiel zeigt, wie man mit VBA auf Webseiten - in diesem Fall auf Kleinanzeigenportale - zugreifen kann und die Inhalte der Webseite auswertet.
Zunächst muss der Verweis (im VBE unter Extras - Verweise auf die Microsoft HTML Object Library gesetzt werden. Dann ist es möglich ein neues Objekt vom Typ MSHTML.HTMLDocument anzulegen. Dieses Objekt kennt die Methode "createDocumentFromUrl", der man im Wesentlichen die URL der Webseite übergibt.

Bei den meisten Portalen ist es möglich, die Suche nach Kleinanzeigen über eine URL und der Angabe des Suchbegriffs zu starten. Findix.com hat das sehr einfach gelöst und bietet die URL http://www.findix.com/suche/ an, die direkt mit dem Suchbegriff verknüpft werden kann d.h. z.B. http://www.findix.com/suche/fahrrad. Bei Quoka ist die Syntax etwas komplizierter (Übergabe des Arguments "Search1" an die cfm Funktion), aber der Suchbegriff kann auch hier einfach hinten an die URL angehängt werden.

Der Aufruf von "createDocumentFromUrl" liefert ein Objekt zurück, dass wesentliche Informationen zur Webseite enthält. Am Einfachsten kann man sich die Struktur und die Details des Objekts im Lokalfenster im Debug-Mode ansehen. In diesem Codebeispiel wird im Element "Body" die innerText-Eigenschaft ausgelesen, die den Webseiten Inhalt enthält.

Anschließend kann beispielhaft in den Ergebnissen in myResults(k).BodyResult mit einer Schleife nach
weiteren Details gesucht werden.

PLAIN TEXT

VBA:

Type SearchWebType
Website As String
HTMLSearchQuery As String
BodyResult As String
End Type
Sub Kleinanzeigen_Suche()
'Verweis notwendig: Microsoft HTML Object Library
'
'HTML Seiten abrufen und Seiteninhalt durchsuchen
'03-2011
'E.Bimczok http://profi-excel.de
'
'Liest beispielhaft die Webseiten der Kleinanzeigenportale
'Findix.com und Quoka.de ein
Dim objMSHTML As New MSHTML.HTMLDocument
Dim myHTMLDoc As New MSHTML.HTMLDocument
Dim myResults() As SearchWebType
Dim myWebsiteSearch As String
Dim subSearchString As String
Dim k As Long
Dim foundPos As Long
ReDim myResults(1 To 2)
myWebsiteSearch = "Fahrrad"
subSearchString = "BMX" 'nach Begriff in den Ergebnissen suchen
myResults(1).Website = "http://www.findix.com"
myResults(1).HTMLSearchQuery = "http://www.findix.com/suche/"
myResults(2).Website = "http://www.quoka.de"
myResults(2).HTMLSearchQuery = "http://www.quoka.de/searchresult.cfm?SEARCH1="
'alle definierten Webseiten abrufen
For k = LBound(myResults) To UBound(myResults)
'z.B. http://www.findix.com/suche/fahrrad
Set myHTMLDoc = objMSHTML.createDocumentFromUrl( _
myResults(k).HTMLSearchQuery & myWebsiteSearch, _
vbNullString)
'Abwarten, bis die Seite geladen ist
While myHTMLDoc.readyState <> "complete"
DoEvents
Wend
myResults(k).BodyResult = myHTMLDoc.body.innerText
Next k
'detaillierte Suche
For k = LBound(myResults) To UBound(myResults)
foundPos = InStr(1, myResults(k).BodyResult, subSearchString, vbTextCompare)
If foundPos> 0 Then
'wenn Begriff gefunden wurde, 20 Zeichen davor
'und 200 Zeichen danach anzeigen
MsgBox ("Webseite: " & myResults(k).Website & vbCr & _
Mid(myResults(k).BodyResult, foundPos - 20, 200))
End If
Next k
End Sub

Suche mit Regular Expressions in VBA

Eike — Fri, 18 Mar 2011 19:28:23 +0000

VBA kennt von sich aus keine Regulären Ausdrücke. Um einen ersten Einstieg in den Umgang mit Regulären Ausdrücken zu bekommen, gibt es unten ein Beispiel, wie man die Bibliothek verfügbar macht.
Über CreateObject erzeugt man das Objekt. Die Pattern Eigenschaft legt das Pattern für die Suche fest, hierbei werden üblicherweise Zeichenklassen verwendet, wie z.B. \w (siehe unten) oder \d für alle Zahlen, d.h. 0-9.
Der Vorteil von Regulären Ausdrücken liegt in den sehr umfassenden Möglichkeiten auch komplexe Suchen bzw. Prüfungen vorzunehmen. Ein übliches Beispiel ist die Prüfung der Gültigkeit von Emailadressen.

PLAIN TEXT

VBA:

Sub VBA_Suche_Mit_RegularExpression()
'sucht mit der Hilfe von Regulären Ausdrücken
'03-2011
'E.Bimczok http://profi-excel.de
Const myText As String = "Dieser Satz kein Verb"
Dim myRegEx As Object
Set myRegEx = CreateObject("VBScript.RegExp")
'\w alle Zahlen (0-9), Buchstaben (A-z) oder "_"
'+ mindestens einmal aber beliebig oft
myRegEx.Pattern = "\w+"
Set result = myRegEx.Execute(myText)
MsgBox result(0).Value 'Dieser
'Buchstabe "S", danach die oben beschriebene Klasse \w
myRegEx.Pattern = "S\w+"
Set result = myRegEx.Execute(myText)
MsgBox result(0).Value 'Satz
End Sub

Mehrfach Suchen und Ersetzen mit Statistik

Eike — Mon, 07 Mar 2011 19:57:37 +0000

Mehrfaches "Suchen und Ersetzen" hat bereits in diesem Artikel viel Interesse erzeugt. Die Frage nach statistischen Informationen ließ sich aber nicht so einfach beantworten. Dazu sind einige Anpassungen am Code notwendig.
Excel bietet über den Aufruf im Menü "Suchen und Ersetzen" von sich aus bereits die Informationen, wie viele Inhalte ersetzt wurden. Leider ist es nach meiner Kenntnis nicht möglich, diese Informationen über VBA direkt zu erreichen. Die Lösung liegt in der Programmierung von zwei verschachtelten Schleifen. Die äußere Schleife durchläuft die Suchbegriffe, die innere Schleife alle Einträge des Tabellenblattes. Der Aufruf der instr-Funktion dient nur dem Erhalt der Information, ob der Suchbegriff in der Zelle vorhanden ist. In diesem Fall wird der Zähler für den jeweiligen Begriff inkrementiert.

Möchte man nicht den "Value" der Zelle ersetzen, kann alternativ auch mittels myCell.FormulaLocal beispielsweise eine Formel ersetzt werden.

PLAIN TEXT

VBA:

Sub mehrfachSuchenUndErsetzenMitStatistik()
'sucht im aktiven Tabellenblatt jeweils die Eintraege aus
'suchArray und ersetzt mit ersetzArray
'03-2011
'E.Bimczok http://profi-excel.de
Dim suchArray()
Dim ersetzArray()
Dim StatistikArray() As Long
Dim k As Long
Dim myCell As Range
Dim Zellinhalt As String
Dim Ausgabe As String
suchArray = Array("a", "b", "c")
ersetzArray = Array("1", "2", "3")
ReDim StatistikArray(LBound(suchArray) To UBound(suchArray))
'alle Suchbegriffe durchlaufen
For k = LBound(suchArray) To UBound(suchArray)
'alle Zellen im verwendeten Bereich durchlaufen
For Each myCell In ActiveSheet.UsedRange
'Ersetzung durchfuehren
Zellinhalt = myCell.Value
If InStr(1, Zellinhalt, suchArray(k), vbTextCompare)> 0 Then
myCell.Value = Replace(Zellinhalt, suchArray(k), ersetzArray(k), , , vbTextCompare)
StatistikArray(k) = StatistikArray(k) + 1
End If
Next myCell
Next k
Ausgabe = "Folgende Ersetzungen wurden durchgeführt:"
For k = LBound(suchArray) To UBound(suchArray)
Ausgabe = Ausgabe & vbCr & suchArray(k) & " --> " & ersetzArray(k) & ": " & StatistikArray(k) & " Ersetzungen"
Next k
MsgBox Ausgabe
End Sub

Excel Diagramm Linien auf schwarz-weiss stellen

Eike — Wed, 13 May 2009 20:07:13 +0000

Falls man in Diagrammen die Linienfarben auf schwarz stellen möchte, lässt sich das einfach mit diesem Makro unterstützen. So lassen sich auf Knopfdruck alle Diagramme innerhalb einer Excel-Datei umstellen.

Zur Funktion des Makros:

Die erste For-Each-Schleife durchläuft alle Blätter der Datei, die zweite Schleife alle Diagramme und die dritte Schleife alle Linien des Diagramms.

Der ColorIndex wird auf 1 gesetzt (schwarz) und der Linienfarbe, dem Marker und der Markerfüllung zugewiesen.

Siehe auch http://www.profi-excel.de/vba_makros/diagramm-linien-einfarben.htm

PLAIN TEXT

VBA:

Sub DiagrammeSW()
Dim mySht As Worksheet
Dim myDia As Object
Dim myLine As Object
Dim lineColorIndex As Long
For Each mySht In ActiveWorkbook.Sheets
For Each myDia In mySht.ChartObjects
For Each myLine In myDia.Chart.SeriesCollection
lineColorIndex = 1
myLine.MarkerBackgroundColorIndex = lineColorIndex
myLine.MarkerForegroundColorIndex = lineColorIndex
myLine.Border.ColorIndex = lineColorIndex
Next myLine
Next myDia
Next mySht
MsgBox "Linien auf schwarz umgestellt"
End Sub

Diagramm Linien einfärben

Eike — Wed, 13 May 2009 19:54:23 +0000

Falls man in Diagrammen die Linienfarben ändern möchte, lässt sich das einfach mit diesem Makro unterstützen. So lassen sich auf Knopfdruck alle Diagramme innerhalb einer Excel-Datei abhängig von der Linienart (Markierung) einfärben.

Zur Funktion des Makros:

Die erste For-Each-Schleife durchläuft alle Blätter der Datei, die zweite Schleife alle Diagramme und die dritte Schleife alle Linien des Diagramms. Abhängig vom MarkerStyle wird in der Select Case Anweisung der ColorIndex definiert.

Der ColorIndex wird dann der Linienfarbe, dem Marker und der Markerfüllung zugewiesen.

PLAIN TEXT

VBA:

Sub DiagrammeFaerben()
'
Dim mySht As Worksheet
Dim myDia As Object
Dim myLine As Object
Dim lineColorIndex As Long
For Each mySht In ActiveWorkbook.Sheets
For Each myDia In mySht.ChartObjects
For Each myLine In myDia.Chart.SeriesCollection
' XlMarkerStyle kann eine der folgenden
' XlMarkerStyle-Konstanten sein.
' xlMarkerStyleAutomatic. Automatische Markierungen.
' xlMarkerStyleCircle. Runde Markierungen.
' xlMarkerStyleDash. Lange Balken als Markierungen.
' xlMarkerStyleDiamond. Rautenförmige Markierungen.
' xlMarkerStyleDot. Kurze Balken als Markierungen.
' xlMarkerStyleNone. Keine Markierung.
' xlMarkerStylePicture. Bildmarkierungen.
' xlMarkerStylePlus. Quadratische Markierungen mit Pluszeichen.
' xlMarkerStyleSquare. Quadratische Markierungen.
' xlMarkerStyleStar Quadratische Markierungen mit Sternchen.
' xlMarkerStyleTriangle. Dreieckige Markierungen.
' xlMarkerStyleX. Quadratische Markierungen mit einem X.
Select Case myLine.MarkerStyle
Case xlMarkerStyleCircle
lineColorIndex = 1
Case xlMarkerStyleDash
lineColorIndex = 2
Case xlDiamond
lineColorIndex = 3
Case xlMarkerStyleDot
lineColorIndex = 4
Case xlMarkerStyleNone
lineColorIndex = 5
Case xlMarkerStylePicture
lineColorIndex = 6
Case xlMarkerStylePlus
lineColorIndex = 7
Case xlMarkerStyleSquare
lineColorIndex = 8
Case xlMarkerStyleStar
lineColorIndex = 9
Case xlMarkerStyleTriangle
lineColorIndex = 10
Case xlMarkerStyleX
lineColorIndex = 11
Case Else
lineColorIndex = 12
End Select
myLine.MarkerBackgroundColorIndex = lineColorIndex
myLine.MarkerForegroundColorIndex = lineColorIndex
myLine.Border.ColorIndex = lineColorIndex
Next myLine
Next myDia
Next mySht
MsgBox "eingefärbt"
End Sub

Doppelte Einträge entfernen und Übereinstimmungen suchen

Eike — Sun, 15 Jun 2008 08:18:39 +0000

Mit einer Collection ist in VBA einiges möglich. Doppelte Einträge lassen sich eliminieren, indem beim Hinzufügen des Elements zur Collection ein eindeutiger "Key" zugewiesen wird. Jeder Key darf nur einmal in der Collection vorhanden sein. Beim zweiten Versuch, ein identisches Element mit dem identischen Key hinzuzufügen, wird der Vorgang mit einer Fehlermeldung abgebrochen. On Error Resume Next verhindert die Fehlermeldung.
Weiterhin lassen sich zwei Collections miteinander vergleichen, indem man versucht, das Element direkt über den Key anzusprechen. Übereinstimmenden Einträge können so einfach aufgefunden werden.

PLAIN TEXT

VBA:

Sub collectionDemo()
'Doppelte Eintraege entfernen und Uebereinstimmungen suchen
'06-2008 By E.Bimczok
Dim BasisArrayA
Dim BasisArrayB
BasisArrayA = Array(1, 3, 5, 7, 8)
BasisArrayB = Array(1, 1, 1, 1, 2, 3, 2, 3, 4, 3, 2, 5, 4)
Dim CollA As New Collection
Dim CollB As New Collection
On Error Resume Next
For k = LBound(BasisArrayA) To UBound(BasisArrayA)
CollA.Add BasisArrayA(k), "x" & BasisArrayA(k)
Next k
For k = LBound(BasisArrayB) To UBound(BasisArrayB)
CollB.Add BasisArrayB(k), "x" & BasisArrayB(k)
Next k
'übereinstimmungen suchen
For Each c In CollA
temp = CollB("x" & c)
If temp = c Then
Stop
'match
Else
Stop
'mismatch
End If
Next c
End Sub

Excel Tabelle in Textform konvertieren

Eike — Fri, 27 Oct 2006 19:41:45 +0000

Der markierte Bereich wird spaltenweise auf die Textlänge untersucht und damit die Breite der Spalten (Anzahl der Buchstaben) festgelegt. Dabei wird die Text-Eigenschaft des Range-Objektes verwendet, so dass der angezeigte Text erscheint.

Das Makro ist besonders geeignet, um Tabellenausschnitte in der Microsoft Excel Newsgroup einzufügen.

Das Ergebnis sieht dann so aus:

PLAIN TEXT

VBA:

+--------+-----------+----------+
|Dieses |Makro |erstellt |
+--------+-----------+----------+
|perfekt |formatierte|ASCII |
+--------+-----------+----------+
|Tabellen|per |Knopfdruck|
+--------+-----------+----------+

Makro als Add-In kostenlos herunterladen (inkl. Menüleiste): Profi-ExcelAdd-In

PLAIN TEXT

VBA:

Sub exportAscii()
'konvertiert den markierten Tabellenbereich in
'eine Tabelle im Textformat
'10-2006
'©E.Bimczok
'http://www.profi-excel.de/
Const mypath As String = "c:\tempAsciiTable.txt"
Dim myRng As Range
Dim myCol As Range
Dim myCell As Range
Dim myLen As Long
Dim maxLen As Long
Dim numRows As Long
Dim numCols As Long
Dim AsciiOut() As String
Dim AsciiCount As Long
Dim fF As Long
Dim noOfSpaces As Long
Dim spaceStr As String
Set myRng = Selection
numRows = myRng.Rows.Count
numCols = myRng.Columns.Count
ReDim AsciiOut(1 To numRows * 2 + 1)
For Each myCol In myRng.Columns
maxLen = 0
For Each myCell In myCol.Rows
myLen = Len(myCell.Text)
maxLen = maxAB(maxLen, myLen)
Next myCell
AsciiCount = 1
For Each myCell In myCol.Rows
AsciiOut(AsciiCount) = AsciiOut(AsciiCount) & _
"+" & String(maxLen, "-")
AsciiCount = AsciiCount + 1
AsciiOut(AsciiCount) = AsciiOut(AsciiCount) & _
"|" & myCell.Text
noOfSpaces = maxLen - Len(myCell.Text)
spaceStr = ""
If noOfSpaces> 0 Then spaceStr = String(noOfSpaces, " ")
AsciiOut(AsciiCount) = AsciiOut(AsciiCount) & spaceStr
AsciiCount = AsciiCount + 1
Next myCell
AsciiOut(numRows * 2 + 1) = AsciiOut(1)
Next myCol
For k = 1 To numRows * 2 + 1
AsciiOut(k) = AsciiOut(k) & Left(AsciiOut(k), 1)
Next k
fF = FreeFile
Open mypath For Output As #fF
For k = 1 To UBound(AsciiOut)
Print #fF, AsciiOut(k)
Next k
Close #fF
Shell "notepad.exe " & mypath, vbNormalFocus
End Sub
Function maxAB(A As Long, B As Long) As Long
If A>= B Then
maxAB = A
Else
maxAB = B
End If
End Function

Zeilennummer von Objekten bestimmen

Eike — Sat, 21 Oct 2006 09:30:09 +0000

Über die for each -Schleife wird auf alle Objekte vom Typ "shape" im aktiven Arbeitsblatt zugegriffen. Das Shape-Objekt hat die Eigenschaft TopLeftCell, die ein Rangeobjekt zurück gibt. Über die row-Eigenschaft lässt sich dann die Zeilennummer des Objektes zurückgeben.

PLAIN TEXT

VBA:

Sub getRowOfShapes()
'shows the row number of the shapes
'10-2006 E.Bimczok
'www.profi-excel.de
Dim myShape As Object
Dim zeile As Long
For Each myShape In ActiveSheet.Shapes
zeile = myShape.TopLeftCell.Row
'shapeAdr = myShape.TopLeftCell.Address(0, 0)
'shapeName = myShape.Name
Stop
Next myShape
End Sub

Makros einbinden

Eike — Sat, 23 Sep 2006 09:59:10 +0000

Grundsätzlich gibt es drei Möglichkeiten, Makros in Excel einzubinden

Makros in einer Arbeitsmappe speichern: Das Makro ist nur für diese Datei verfügbar.
Makros in der Makroarbeitsmappe "Personal.xls" speichern: Das Makro ist nur für diesen Computer, aber für alle Dateien verfügbar.
Makros als Add-In speichern: Das Makro ist nur für diesen Computer, aber für alle Dateien verfügbar. Das Add-In lässt sich - wie eine Datei - einfach weitergeben

A.) Wenn Sie ein Makro nur in einer bestimmten Datei verwenden wollen, können Sie das Makro in dieser Datei abspeichern. Das hat den Vorteil, dass Sie die Datei einfach an andere weitergeben können und die Funktionalität des Makros weiterhin vorhanden ist. Das Makro funktioniert allerdings nur, wenn die Datei, in der das Makro gespeichert wurde, auch geöffnet ist. Wollen Sie das Makro also in verschiedenen Dateien anwenden, so sollten Sie B.) oder C.) verwenden, oder in Einzelfällen auch das Makro jeweils in die betroffenen Dateien kopieren. Das hat allerdings den Nachteil, dass Sie Änderungen am Makro-Code (und die gibt es erfahrungsgemäß fast immer) in allen Dateien nachziehen müssen.
Zum Einbinden des Makros-Codes in der Datei gehen Sie wie folgt vor:

Öffnen Sie den Makro-Editor (VBE - Visual Basic Editor) mit der Tastenkombination Alt+F11 oder gehen Sie über den Menüpunkt Extras - Makro - Visual Basic Editor
Sie sehen überlicherweise links oben die VBA-Projektübersicht (siehe Bild 1), in der alle offenen Arbeitsmappen sowie alle geladenen Add-Ins angezeigt werden.
Markieren Sie ein beliebiges Objekt, beispielsweise eine Tabelle in der Arbeitsmappe, in der Sie das Makro einfügen möchten. Hier im Beispiel von Bild 1 ist das Mappe1, Tabelle1. Anschließend müssen Sie über den Menüpunkt Einfügen - Modul ein neues Modul hinzufügen. Das Ergebnis sollte ähnlich dem in Bild 2 sein.
Sie sollten nun das Eingabefenster für den Makro-Code entsprechend Bild 3 sehen. Hier können Sie eigenen Code programmieren oder Makros per Copy-and-paste einfügen.
Wenn Sie die Datei abspeichern, wird der eingegebene Makrocode automatisch mit der Datei gespeichert, genau wie Daten in den Tabellenblättern.

Bild 1

Bild 2

Bild 3

B.) Zum Einbinden von Makros in die Persönliche Makroarbeitsmappe gehen Sie genauso vor wie bei A.), nur dass Sie in der VBA-Projektübersicht (Bild 1) die Personl.xls auswählen. Falls diese noch nicht vorhanden ist, müssen Sie sich diese Datei erzeugen, in dem Sie ein Makro aufzeichnen, siehe Bild 4. Gehen Sie dazu in Excel (also nicht im Makro Editor) auf den Menüpunkt Extras - Makro - Aufzeichnen und zeichnen Sie eine beliebige Aktion, z.B. die Eingabe einer Zahl als Makro in der Personl.xls auf. Danach sollte die Personl.xls in der VBA-Projektübersicht erscheinen.

Bild 4

C.) Für das Abspeichern eines Makros in einem Add-In müssen Sie genau so vorgehen wie bei A.), nur, dass Sie die Datei nicht als normale Excel Datei mit der Endung .xls abspeichern, sondern über den Menüpunkt Datei - Speichern unter - Dateityp: Microsoft Excel-Add-In(*.xla) die Datei als Add-In abspeichern.

Mehrfach Suchen und Ersetzen

Eike — Thu, 21 Sep 2006 20:21:36 +0000

In den beiden Arrays können die korresponierenden Begriffe eingetragen werden. Momentan werden die Buchstaben a durch 1, b durch 2, usw. ersetzt. Die Inhalte in den Arrays müssen natürlich den Bedürfnissen angepasst werden. Durch die For-Schleife werden die jeweiligen Einträge des Arrays der Replace-Methode des Range-Objekts übergeben. Das Range-Objekt stellt hier den benutzten Bereich des aktiven Tabellenblatts dar.

PLAIN TEXT

VBA:

Sub mehrfachSuchenUndErsetzen()
'sucht im aktiven Tabellenblatt jeweils die Eintraege aus
'suchArray und ersetzt mit ersetzArray
'09-2006
'E.Bimczok http://profi-excel.de
Dim suchArray()
Dim ersetzArray()
Dim k As Long
suchArray = Array("a", "b", "c")
ersetzArray = Array("1", "2", "3")
For k = LBound(suchArray) To UBound(suchArray)
Call ActiveSheet.UsedRange.Replace(suchArray(k), _
ersetzArray(k), _
, _
, _
False)
Next k
End Sub