Adressliste aller Stadtwerke in Deutschland
Hallo HaD,
starte die nachstehende Prozedur „Start“. Sie braucht einige Stunden.
In Tabelle1!K1:K2 steht anschließend die Anfangs- und Endzeit der Prozedur.
Den Fortschritt erkennst du in Excel unten links in der Statusleiste.
Nach Durchlauf hast du im Blatt „tabelle1“ die gewünschte Auflistung.
in K1:K2 stehen die Anfangs- und Endzeit der Prozeduren.
Wenn du die anderen 1089 Blätter nicht (mehr) brauchst so starte die Prozedur „Loesch“.
Option Explicit
Public T
Sub Start()
T = Now
Call Loesch
Call A\_Z
Call Zeige
End Sub
Sub Zeige()
Dim N As Long, Anz As Integer, S
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
.UsedRange.Clear
.Range("A1:J1").Value = \_
Split("Blattname Stadtwerk Straße Plz Ort Fax Telefon Mail Web Sonstiges")
Anz = Worksheets.Count - 1
For N = 2 To Worksheets.Count
Application.StatusBar = \_
"Phase 3/3 Auswerte Blatt " & Format(N - 1, "0000") & " von " & Anz
Worksheets(N).Hyperlinks.Add Anchor:=Worksheets(N).Range("B1"), Address:="", SubAddress:= \_
"Tabelle1!A1", TextToDisplay:="Zurück zu Tabelle1"
.Hyperlinks.Add Anchor:=.Cells(N, 1), Address:="", SubAddress:= \_
Worksheets(N).Name & "!A1", TextToDisplay:=Worksheets(N).Name 'Blattname
If N 602 Then
.Cells(N, 2).Value = Worksheets(N).Range("A6").Value 'Name
.Cells(N, 3).Value = Worksheets(N).Range("A7").Value 'Straße
.Cells(N, 4).Value = Split(Worksheets(N).Range("A8").Value)(0) 'Plz
.Cells(N, 5).Value = Split(Worksheets(N).Range("A8").Value)(1) 'Ort
Set S = Worksheets(N).Range("A6:A50").Find("Fax:", , xlValues)
If Not S Is Nothing Then
.Cells(N, 6).Value = Mid(S.Value, 5) 'Fax
Else
.Cells(N, 6).Value = "keine"
End If
Set S = Worksheets(N).Range("A6:A50").Find("Telefon:", , xlValues)
If Not S Is Nothing Then
.Cells(N, 7).Value = Mid(S.Value, 10) 'Tel
Else
.Cells(N, 7).Value = "keine"
End If
Set S = Worksheets(N).Range("A6:A50").Find("@", , xlValues)
If Not S Is Nothing Then
.Cells(N, 8).Value = S.Value 'Mail
Else
.Cells(N, 8).Value = "keine"
End If
Set S = Worksheets(N).Range("A6:A50").Find("www", , xlValues)
If Not S Is Nothing Then
.Hyperlinks.Add Anchor:=.Cells(N, 9), Address:= \_
"http://" & Mid(S.Value, 3), TextToDisplay:="http://" & Mid(S.Value, 3)
.Cells(N, 9).Value = "http://" & Mid(S.Value, 3) 'Web
Else
.Cells(N, 9).Value = "keine"
End If
Else
.Cells(N, 2).Value = "Fehler" 'Fehler
End If
Next N
.Activate
.Range("B2").Select
ActiveWindow.FreezePanes = True
.Range("K1").Value = T
.Range("K2").Value = Now
.Columns("A:K").AutoFit
.Columns(4).NumberFormat = "00000"
.Range("A2").Select
End With
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub A\_Z()
Dim N As Integer, Anz As Integer
Application.ScreenUpdating = False
Anz = 11093 - 10004 + 1
For N = 10004 To 11093
Application.StatusBar = \_
"Phase 2/3 Erstelle Blatt " & Format(N - 10003, "0000") & " von " & Anz
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Blatt" & N
With Worksheets("Blatt" & N).QueryTables.Add(Connection:= \_
"URL;http://www.stadtwerke-in-deutschland.de/adressen.php?info=" & N, \_
Destination:=Range("A1"))
.Name = "index.php?buchstabe=" & N
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
End With
Next N
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub Loesch()
Dim wks As Worksheet, Anz As Integer, N As Integer
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Anz = ThisWorkbook.Worksheets.Count - 1
For Each wks In ThisWorkbook.Worksheets
If wks.Name Like "Stadt\*" Or wks.Name Like "Blatt\*" Then
N = N + 1
Application.StatusBar = \_
"Phase 1/3 Lösche Blatt " & Format(N, "0000") & " von " & Anz
wks.Delete
End If
Next wks
Application.DisplayAlerts = True
On Error GoTo 0
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
