Profi-Excel.de

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

Firefox Shortcut Next Page für Foren und Suchergebnisse

Eike — Sun, 24 Oct 2010 12:12:09 +0000

Die meisten Foren oder Suchmaschinen stellen die Seiten so dar, dass z.B. die ersten 20 Ergebnisse auf der ersten Seite angezeigt werden, Ergebnisse 21-40 auf der zweiten Seite usw. Die Ergebnisseiten sind wiederum durchnummeriert und entweder durch eine Klick auf die Seitennummer oder über "next page" erreichbar.

Leider sind die Links für "next page" oder "Seite 2" häufig extrem klein, d.h man muss relativ genau mit der Maus zielen, um den Link anzuklicken. Speziell bei Notebooks kann das unterwegs zur Geduldsprobe werden, diese unergonomisch kleinen Schaltflächen zu treffen.

Abhilfe schafft das Firefox-Plug-In "SmartPager". Über die Tastenkombination "Alt+ Bild-nach-unten" kann auf die nächste Seite geblättert werden. Alternativ kann auch die Kombination "Alt Gr + Bild-nach-unten" verwendet werden, dann liegen die beiden Tasten sehr ergonomisch, um mit der rechten Hand bedient zu werden.

Insbesondere beim längeren Lesen in Foren lässt sich der berüchtigte "Maus-Arm" durch die wesentliche bessere Ergonomie vermeiden.

Google-Shortcuts

Eike — Sun, 24 Oct 2010 11:38:47 +0000

Wer gerne mit der Tastatur arbeitet, kann dies sehr gut mit einem Plug-In für den Firefox unterstützen.

Aber zunächst die Anleitung, wie man über die Tastatur suchen kann: Mit Strg+k gelangt man in das Suchfenster, nach Eingabe des Suchbegriffs und Drücken der "Enter-Taste" werden die Suchergebnisse dargestellt.

Plug-In "Search Keys"

Das genannte Plug-In nummeriert nun die Suchergebnisse automatisch durch. D.h. das erste Suchergebnis hat die Nummer 1, das zweite die Nummer 2 usw. Jetzt lassen sich die Suchergebnisse über die entsprechenden Nummern auf der Tastatur öffnen. D.h. die das Zeichen 1 auf der Tastatur öffnet das erste Suchergebnis. Mit gedrückter Alt-Taste lassen sich die Suchergebnisse in einem neuen Tab öffnen.

Suchergebnisse mit Search-Keys im Firefox

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