Office: (Office 2013) Alle Zeilen bearbeiten

Hallo liebe Excelfreunde,

Ich habe hier ein sehr nützlichen VBA-Code übernommen und bei mir im Tabellenblatt1 eingebaut.

Dann habe ich im Tabellenblatt2 eine Liste von Geo-Daten eingetragen welche über eine Suchabfrage zusammengestellt werden. Über einen VBA-Button werden die ermittelten GEO-Daten dann in das Tabellenblatt 1 eins kopiert. Der hier zur Verfügung gestellte VBA-Code gibt mir dann auch wie gewünscht in der ersten Zeile die Straßennamen und Hausnummern raus und ermittelt dann auch die Entfernung.

Aber leider nur die erste Zeile. Alle anderen gefüllten Zeilen leider nicht. Wobei die Liste je nach Suchanfrage unterschiedlich lang ist.

Meine Frage ist nun, wie bekomme ich Excel dazu auch für die anderen gefüllten Zeilen eine Abfrage bei Google zu machen und mir so Straße und Hausnummer auszugeben.

Ich hoffe ihr könnt mir weiterhelfen.

Ganz liebe Grüße
Andreas

 

Gesundes neues Jahr wünsche ich euch allen

Ich wollte noch mal fragen, ob mir jemand bei meinem Problem helfen kann.

Liebe Grüße
Andreas

 

Hallo Andreas!
Findest Du nicht, dass zur Beantwortung Deiner Frage Deine Mappe incl. Code notwendig wäre?
Wie soll man Dir sonst helfen?

Gruß Ralf

 

Hallo Ralf,

Die Datei ist für das Forum hier zu groß

Daher kann ich leider nur den Code anbieten

Option Explicit


Private Sub CommandButton1_Click()
Worksheets("Tabelle3").Range("q2:r250").Copy
Worksheets("Tabelle1").Range("a2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

End Sub




'Hinweis:
'Bim Kopieren in ein neues Projekt muss ein Verweis auf "MicrosoftXML, V#.##" gesetzt werden.


'Sub zum Anzeigen der Route im Browser bei Doppelklick:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo Er

If Intersect(Range("A2:E150" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row), Target) Is Nothing Then Exit Sub


Dim GMaps As clsGMaps
Dim s As String

Set GMaps = New clsGMaps
If MapCells(GMaps, Target) Then
s = GMaps.CreateUrl
If Len(s) > 0 Then ActiveWorkbook.FollowHyperlink Address:=s, NewWindow:=True
End If

Ex:
Set GMaps = Nothing
Exit Sub
Er:
Application.Cursor = xlDefault
MsgBox CreateErrorMsgText(Err.Number, Err.Description), vbCritical, "Sub: Worksheet_BeforeDoubleClick in Tabelle1"
Resume Ex
'For debug:
Resume
'End Sub

'Sub für Ermittlung der Entfernung:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Er
If Intersect(Range("A2:B150" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row), Target) Is Nothing Then Exit Sub


Dim GMaps As clsGMaps
Set GMaps = New clsGMaps
If MapCells(GMaps, Target) Then GMaps.GetGoogleMaps

Ex:
Set GMaps = Nothing
Exit Sub
Er:
Application.Cursor = xlDefault
MsgBox CreateErrorMsgText(Err.Number, Err.Description), vbCritical, "Sub: Worksheet_Change in Tabelle1"
Resume Ex
'For debug:
Resume
End Sub

Private Function MapCells(ByVal o As clsGMaps, Target As Range) As Boolean
On Error GoTo Er

'Hier jeweils die Zellen zuweisen
'Es müssen mindestens die Zellen für Start- und Zieladresse zugewiesen werden
'alle anderen Felder sind optional...
With o.Cells
'Pflichtfelder:
.StartAddress = ActiveSheet.Cells(Target.Row, 1)
.EndAddress = ActiveSheet.Cells(Target.Row, 2)

'optionale Felder:
.KM = ActiveSheet.Cells(Target.Row, 3)
.Time = ActiveSheet.Cells(Target.Row, 4)
.Link = ActiveSheet.Cells(Target.Row, 5)

'ebenfalls optional
'In diesem Beispiel werden die von GoogleMaps ermittelten
'Start und Zieladressen in das ursprüngliche Erfassungsfeld eingetragen.
'Also in Spalte A und B.
'Man kann diese Zuweisung auch weglassen oder andere Spalten zuweisen...
.GMapsStartAddress = ActiveSheet.Cells(Target.Row, 1)
.GMapsEndAddress = ActiveSheet.Cells(Target.Row, 2)
End With
MapCells = True

Ex:
Exit Function
Er:
Application.Cursor = xlDefault
MsgBox CreateErrorMsgText(Err.Number, Err.Description), vbCritical, "Sub: ReadGMaps in Tabelle1"
Resume Ex
'For debug:
Resume
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim i As Integer
Cells.Interior.ColorIndex = xlNone
i = ActiveCell.Row
If i >= 2 Then Range(Cells(i, 1), Cells(i, 5)).Interior.ColorIndex = 8
End Sub

Sub AktualisiereZellen()
Application.CalculateFull
End Sub

'Private Sub Worksheet_Activate()

'Calculate

' End Sub
If Not Intersect(Me.Range("a:a"), Target) Is Nothing Then
Call macro
End If
Sub Zellen_fuellen()
Dim f As Object
Set f = Application.WorksheetFunction

For Zeile = 2 To 250 'Hier musst du die Zeilen angeben, die bearbeitet werden sollen!

If Not IsEmpty(Worksheets("Data1").Cells(Zeile, 1)) And _
Not IsEmpty(Worksheets("Data2").Cells(Zeile, 1)) Then

With Worksheets("Calc2")

For i = 1 To 2
myrange = Worksheets("Data" & i).Range("B" & Zeile & ":IV" & Zeile)
If f.Count(myrange) <> 0 Then 'Kein Teilen durch Null möglich!
.Cells(Zeile, 1 + i) = f.Sum(myrange) / f.Count(myrange)
End If
Next i

.Cells(Zeile, 4) = .Cells(Zeile, 2) - .Cells(Zeile, 3)

End With

End If

Next Zeile

End Sub

Ich muss dazu sagen, dass ich ein absoluter VBA-Laie bin.

Gruß
Andreas