Es ist zum Haare raufen...
22.11.2013 12:07:16
EtoPHG
Jens,
du verfällst immer wieder in den gleichen Teufelskreis, oder was soll ich mit Zitat: "...in tabellenblatt Ergebnis in die gleiche Zeile geschrieben werden wie der Zähler "r"" und Zitat:"Das nachträgliche kopieren kann man sicherlich anders lösen. Mein Problem..." anfangen? Bitte überdenke nochmals deinen gewählten Excel/VBA Level!
Ich versuch mal, dich zu deinem Glück zu zwingen. ;-)
In deiner hochgeladenen Datei: Lösche deinen gesamten Code und ersetze ihn durch diesen:
Sub WegWerfen()
' Nach einmaligem Gebrauch löschen!
With ThisWorkbook.Worksheets("Kopieren").QueryTables(1)
If .Name "WebAbfrage" Then
.Name = "WebAbfrage"
.BackgroundQuery = False
End If
End With
End Sub
Sub getAdressListe()
Dim rCell As Range
Dim lRowA As Long, lRowZ As Long
Dim wsA As Worksheet
Dim wsQ As Worksheet
Dim wsZ As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set wsA = ThisWorkbook.Worksheets("Adressen")
Set wsQ = ThisWorkbook.Worksheets("Kopieren")
Set wsZ = ThisWorkbook.Worksheets("Ergebnis")
wsZ.UsedRange.Clear
wsZ.Cells(1, 1) = "Gemeinde-Name"
wsZ.Cells(1, 2) = "Anschrift 1"
wsZ.Cells(1, 3) = "Anschrift 2"
wsZ.Cells(1, 4) = "Anschrift 3"
wsZ.Cells(1, 5) = "Anschrift 4"
wsZ.Cells(1, 6) = "Anschrift 5"
wsZ.Cells(1, 7) = "Telefon:"
wsZ.Cells(1, 8) = "E-Mail:"
wsZ.Cells(1, 9) = "Homepage:"
lRowZ = 2
For lRowA = 2 To wsA.Cells(wsA.Rows.Count, 2).End(xlUp).Row
Application.StatusBar = "Abfrage Gemeinde: " & wsA.Cells(lRowA, 2)
With wsQ.QueryTables("WebAbfrage")
.Connection = "URL;http://www.statistik.baden-wuerttemberg.de/Online-Verzeichnisse/Gem.asp?G=" & _
_
wsA.Cells(lRowA, 4).Text
.Refresh BackgroundQuery:=False
End With
wsZ.Cells(lRowZ, 1) = wsQ.Cells(15, 2).Text
wsZ.Cells(lRowZ, 2) = wsQ.Cells(19, 2).Text
wsZ.Cells(lRowZ, 3) = wsQ.Cells(20, 2).Text
wsZ.Cells(lRowZ, 4) = wsQ.Cells(21, 2).Text
If InStr(wsQ.Cells(23, 2).Text, wsZ.Cells(1, 7)) Then
wsZ.Cells(lRowZ, 7) = Replace(wsQ.Cells(23, 2).Text, wsZ.Cells(1, 7), "")
Else
wsZ.Cells(lRowZ, 5) = wsQ.Cells(23, 2).Text
wsZ.Cells(lRowZ, 6) = wsQ.Cells(24, 2).Text
wsZ.Cells(lRowZ, 7) = Replace(wsQ.Cells(26, 2).Text, wsZ.Cells(1, 7), "")
End If
wsZ.Cells(lRowZ, 8) = Replace(wsQ.Cells(28, 2).Text, wsZ.Cells(1, 8), "")
wsZ.Cells(lRowZ, 9) = Replace(wsQ.Cells(30, 2).Text, wsZ.Cells(1, 9), "")
lRowZ = lRowZ + 1
Next lRowA
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Die Prozedur "WegWerfen" einmal aufrufen. Anschliessend kannst du deren Codezeilen löschen.
Die Prozedur "getAdressListe" aufrufen und das "Ergebnis" anschauen. Die Prozedur kann beliebig oft wiederholt werden, insbesondere, wenn sich etwas auf dem Blatt "Adressen" ändert.
Gib bitte eine Rückmeldung, ob das Ergebnis ungefähr deinen Erwartungen entspricht.
Gruess Hansueli