Umbau der Eingabe

Simon · 2024-10-06T18:47:02+00:00

Hallo... das ist meine VBA einigen sicher bekannt... da Nutzer dieser Tabelle wo dies genutzt wird noch alte Excel Versionen haben oder ein anderes Programm verwenden habe ich folgende Idee gehabt... VBA: Sub AusZwischenablage_zwischen_Klammern01() Dim DaOb As DataObject Dim txt As String Dim Pos1 As Long Dim Pos2 As Long '----------------------------------------------------- ' Vor erstellen des Codes ' aktiviere unter EXTRAS - VERWEISE den Verweis: ' Microsoft Forms 2.0 Object Library '----------------------------------------------------- 'text aus zwischenablage holen Set DaOb = New DataObject DaOb.GetFromClipboard txt = DaOb.GetText 'text zwischen eckigen Klammern ermitteln Pos1 = InStr(txt, "Incoming") Pos1 = InStr(Pos1, txt, "[") Pos2 = InStr(Pos1, txt, "]") If Pos1 > 0 And Pos2 > Pos1 Then txt = Left(txt, Pos2 - 1) txt = Mid(txt, Pos1 + 1) 'Text in feste Zelle einfügen ActiveSheet.Range("B3") = Replace(txt, vbCrLf, "") ActiveSheet.Range("B3") = Replace(Range("B3"), " 49,", "") Else Beep End If Die Daten in B3 könnten dann so aussehen... 1, 2, 4, 9, 5, 6, 7, 3, 14, 11, 10, 8, 12, 13, 15, 17, 16, 18, 20, 19, 25, 21, 22, 23 oder auch leer sein weil es "Incoming" zweimal gibt und das erste leer ist... Zahlenlänge ist unterschiedlich je nach Level der Stadt. Die Frage der Anwender ist folgende. Könnte man per VBA immer die letzten 4 der Reihe in je eine Zelle schreiben... Hier also so: H3 = 25 I3 = 21 J3 = 22 K3 =23 Danke für Eure gute Hilfe.

Hallo Simon,

hier mal der angepasste Code zum Extrahieren der Incoming-Werte.
Ich hoffe es funktioniert jetzt bei Dir.

Es wird jetzt der Text aus der Zwischenablage so wie in den Textdateien ausgewiesen korrekt verarbeitet. Bisher konnte es nicht funktionieren, denn der Text in der Textdatei entspricht nicht dem, was Du hier im Form gezeigt hast. Und das war ja mein Reden....
So sind Zeilenumbrüche hinter den Werten, Items sind in Anführungsstrichen, die Werte haben mehrfache Leerzeichen vor sich usw..
Und auch jetzt finde ich in der Forefox-Version nur einmal Incoming.
Jetzt wird die letzte (oder einzige) Incoming ausgewertet, egal wieviel davor noch stehen.

Code:


Option Explicit
'-----------------------------------------------------
' Vor erstellen des Codes
' aktiviere unter EXTRAS - VERWEISE den Verweis:
' Microsoft Forms 2.0 Object Library
'-----------------------------------------------------

Sub AusZwischenablage_zwischen_Klammern01()
  Dim DaOb As DataObject, WSh As Worksheet
  Dim sTxt As String, sArr() As String
  Dim i As Long, L As Long, iSp As Long, iZl As Long
  
  Set WSh = ThisWorkbook.Sheets("Tabelle1")               ' Ausgabeblatt setzen
  iZl = 3                                                 ' Ausgabezeile
  Set DaOb = New DataObject
  DaOb.GetFromClipboard                                   ' Text aus Zwischenablage holen

  sTxt = Replace(Replace(Replace(DaOb.GetText, vbCr, ""), vbLf, ""), Chr(34), "")
  sArr = Split(sTxt, "Incoming: [")                       ' Text aufsplitten
  i = UBound(sArr)
  If i > 0 Then                                           ' Richtiger Text in Zwischenablage?
     sTxt = Replace(Split(sArr(i), "]")(0), " ", "")      ' Leerzeichen entfernen
     sTxt = Replace(sTxt, ",49,", ",")                    ' 49 entfernen
     sArr = Split(sTxt, ",")                              ' Text aufsplitten

' Text in feste Zelle(n) einfügen
     i = UBound(sArr) - 3: If i < 0 Then i = 0            ' Item-Beginn festlegen
     
     For iSp = 8 To 11                                    ' Extraausgaben
         If i <= UBound(sArr) Then
            WSh.Cells(iZl, iSp).Value = sArr(i)           ' Item ausgeben
            L = L + Len(sArr(i)) + 1                      ' Item-Längen aufaddieren
         Else
            WSh.Cells(iZl, iSp).Value = ""                ' ggf. Feld löschen
         End If
         i = i + 1                                        ' Nächstes Item
     Next iSp
            
     WSh.Cells(iZl, "B").Value = ""                       ' Feld B3 erst mal leeren
     If L >= Len(sTxt) Then Exit Sub                      ' Keine Daten mehr =>raus
     sTxt = Left$(sTxt, Len(sTxt) - L)                    ' Text um die 4 Items kürzen
     WSh.Cells(iZl, "B").Value = Replace(sTxt, ",", ", ") ' Text formatiert ausgeben
  Else
     MsgBox "In der Zwischenablage befindet sich kein passender Text!", vbCritical
  End If
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Hallo Simon,

versuche den Code in der besagte Anlage 172422.xlsx zu lesen, laut und auf Deutsch. Du wirst merken, dass es nicht so kompliziert zu verstehen, wie es zuerst aussieht.
Mache Dir danach Gedanken, wie Du diesen Code anpassen müsste, um deine Daten aus deiner Web-Quelle zu lesen und einen Text-Variable zu übergeben.

Mache verschiedene Versuche, eventuell in Schritt-Modus (F8) und mit geöffnetem Lokalfenster, um den Stand der Variablen zu beobachten. Es hilft nicht viel, wenn wir das Problem komplett lösen, aber Du verstehst nichts davon.

Also Schritte 1: Diese Code verstehen, und schauen was angepasst werden muss

' API-Schlüssel hier eintragen

Const APIKey As String = "xxxxx" 'anpassen



Sub test()

    GetIncoming "testwert1" 'anpassen

End Sub



Function GetIncoming(adresse As String) As String

    Dim http As Object

    Dim jsonResponse As String

    Dim json As Object

    Dim abgefragteURL As String

    Dim coordinates As String

    

' Geocoding-URL erstellen

    abgefragteURL = "https://api.openrouteservice.org/geocode/search?api_key=" & APIKey & "&text=" & adresse

    

' Debugging: URL anzeigen

    Debug.Print "abgefragte URL: " & abgefragteURL

   

' HTTP-Anfrage senden

    Set http = CreateObject("MSXML2.XMLHTTP")

    http.Open "GET", abgefragteURL, False

    http.send

    jsonResponse = http.responseText



' Debugging: Antwort anzeigen

    Debug.Print "Response: " & jsonResponse

    

    ' Überprüfen, ob eine Antwort erhalten wurde

    If jsonResponse > "" Then

        ' JSON analysieren

        On Error GoTo JSONError

        Set json = JsonConverter.ParseJson(jsonResponse)

        '... HIER KOMMT NOCH WAS

        GetIncoming = ...

    Else

        Debug.Print "Leere Antwort von der API."

    End If

    Exit Function



JSONError:

    Debug.Print "Fehler beim Parsen der JSON-Antwort: " & Err.Description

End Function

Der json selbst sieht aus, wie von Dir gepostet: https://www.herber.de/forum/archiv/1992to1996/1992843_VBA_aendern_verbessern.html#1992893

VG
Yal

Forumthread: Umbau der Eingabe

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Umbau der Eingabe

Forumthread: Umbau der Eingabe

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread