Teile einer Text Datein in Excel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi,
ok die Frage ist etwas konfus formuliert.
Wie gesagt, die Textdatei hat immer das gleiche Schema. Die sehen dann so aus:
{
"id": "4d388d249784a093fa44e1e8",
"name": "San Francisco Coffee Company",
"contact": {
"phone": "08950222548",
"formattedPhone": "089 50222548"
},
"location": {
"address": "Theresienhöhe 12",
"crossStreet": "Franziska-Bilek-Weg",
"lat": 48.133665882709465,
"lng": 11.544219805221282,
"distance": 177,
"postalCode": "80339",
"city": "München",
"country": "Germany",
"cc": "DE"
},
"canonicalUrl": "https://foursquare.com/v/san-francisco-coffee-company/4d388d249784a093fa44e1e8",
"categories": [
{
"id": "4bf58dd8d48988d1e0931735",
"name": "Coffee Shop",
"pluralName": "Coffee Shops",
"shortName": "Coffee Shop",
"icon": "https://foursquare.com/img/categories/food/coffeeshop.png",
"parents": [
"Food"
],
"primary": true
}
],
"verified": false,
"stats": {
"checkinsCount": 960,
"usersCount": 208,
"tipCount": 1
},
"likes": {
"count": 0,
"groups": []
},
"beenHere": {
"count": 0
}
},
{
"id": "4e0f7e2f7d8bb178a8b33f35",
"name": "Abant",
"contact": {},
"location": {
"lat": 48.13375113288785,
.
.
.
Das ist eine Ausgabe aus der Foursquare API. Davon habe ich ca. 1500.
Ich würde jetzt gerne einige der Werte dieser 1500 Ausgaben in eine übersichtliche Tabelle bekommen.
Die Tabelle hätte folgende Felder:
Spalte A Spalte B Spalte C Spalte D Spalte E Spalte F Spalte G Spalte H
Nummer Name Address postalCode lat long CheckinsCount userCount
(die Nummer würde ich einfach nach unten ziehen: 1500)
Das Makro würde also wie folgt vorgehen:
erstes Feld auslesen = wenn "Name" gefunden, diesen Wert dann in B2
darauffolgender Wert für Address in C2
postalCode in D2
lat in E2
.
.
.
Außerdem müsste das Makro jedes zweite "Name" vernachlässigen, da ja diese Kategorie leider zweimal pro Venue vorkommt (beim zweiten Mal ist es eine Untekategorie, die ich nicht brauche)
Mein bisheriger Ansatz:
Sub Tabelle Foursquare
'hier meine 7 Ausgabespalten
Dim name as String
Dim address as String
Dim postalCode as Integer
Dim lat as Double
Dim long as Double
Dim checkinsCount as Long
Dim userscount as Long
open "C:\ (Addresse meiner txt Datei)
'jetzt müsste ich die 7 Ausgaben irgendwie erfassen können
worksheets("Roh_4sq").Range("b2-b1501") = inputbox(" ")
wie man sieht, bin ich nicht wirklich voran gekommen...

Sub aaa() Dim sTmp, i As Long, j As Integer, n As Integer, arrTmp, sItem As String, bln As Boolean Dim objDaten As Object, arrDaten(), arr(7) Set objDaten = CreateObject("Scripting.Dictionary") Open "c:\temp\test.txt" For Input As #1 sTmp = Split(Input(LOF(1), 1), vbCrLf) Close #1 objDaten(0) = Array("Nr.", "Name", "address", "lat", "lng", "postalCode", "checkinscount", " _ userscount") For i = 0 To UBound(sTmp) arrTmp = Split(sTmp(i), ":") If UBound(arrTmp) > 0 Then sItem = Trim(Replace(arrTmp(1), Chr(34), "")) sItem = Left(sItem, Len(sItem) - 1) Select Case LCase(Trim(Replace(arrTmp(0), Chr(34), ""))) Case "id" bln = Not bln n = n - bln If bln Then Erase arr Case "name" If bln Then arr(0) = n arr(1) = sItem End If Case "address": arr(2) = sItem Case "lat": arr(3) = sItem Case "lng": arr(4) = sItem Case "postalcode": arr(5) = sItem Case "checkinscount": arr(6) = sItem Case "userscount": arr(7) = sItem End Select objDaten(n) = arr End If Next ReDim arrDaten(1 To objDaten.Count, 1 To 8) For i = 0 To n arrTmp = objDaten(i) For j = 0 To 7 arrDaten(i + 1, j + 1) = arrTmp(j) Next Next Sheets(1).Cells(1, 1).Resize(UBound(arrDaten), UBound(arrDaten, 2)) = arrDaten End Sub

Sub ramona() Dim sTmp, i As Long, j As Integer, n As Integer Dim arrTmp, sItem As String, blnCat As Boolean Dim objDaten As Object, arrDaten(), arr() Dim arrHeader Dim sFile As String arrHeader = Array("Nr.", "Name", "loc_address", _ "loc_postal", "canonical_url", "loc_lat", "loc_lng", _ "cat_name", "stats_checkinscount", "stats_userscount ") ReDim arr(UBound(arrHeader)) With Application.FileDialog(msoFileDialogFilePicker) .Title = "Datei wählen" .AllowMultiSelect = False If .Show = -1 Then sFile = .SelectedItems(1) End If End With If sFile "" Then Set objDaten = CreateObject("Scripting.Dictionary") Open sFile For Input As #1 sTmp = Split(Input(LOF(1), 1), vbCrLf) Close #1 Do 'erste ID suchen arrTmp = Split(sTmp(i), ":") If UBound(arrTmp) > 0 Then If LCase(Trim(Replace(arrTmp(0), Chr(34), ""))) = "id" Then Exit Do End If End If i = i + 1 Loop Do arrTmp = Split(sTmp(i), ":") If UBound(arrTmp) > 0 Then sItem = Trim(Replace(arrTmp(1), Chr(34), "")) If Len(arrTmp(1)) Then sItem = Left(sItem, Len(sItem) - 1) Select Case LCase(Trim(Replace(arrTmp(0), Chr(34), ""))) Case "categories": blnCat = True Case "id" n = n + 1 + blnCat If Not blnCat Then ReDim arr(UBound(arrHeader)) Case "name" If blnCat Then arr(7) = sItem blnCat = False Else arr(0) = n arr(1) = sItem End If Case "address": arr(2) = sItem Case "postalcode": arr(3) = sItem Case "canonicalurl": arr(4) = sItem & Left(arrTmp(2), Len(arrTmp(2)) - 2) Case "lat": arr(5) = sItem Case "lng": arr(6) = sItem Case "checkinscount": arr(8) = sItem Case "userscount": arr(9) = sItem End Select objDaten(n) = arr End If End If i = i + 1 Loop Until i > UBound(sTmp) objDaten(0) = arrHeader ReDim arrDaten(1 To objDaten.Count, 1 To UBound(arrHeader) + 1) For i = 0 To n arrTmp = objDaten(i) For j = 0 To UBound(arrHeader) arrDaten(i + 1, j + 1) = arrTmp(j) Next Next With Sheets(1) .Cells.Clear .Cells(1, 1).Resize(UBound(arrDaten), UBound(arrDaten, 2)) = arrDaten End With End If End Sub

Sub ramona() Dim sTmp, i As Long, j As Integer, n As Integer Dim arrTmp, sItem As String, bln As Boolean Dim objDaten As Object, arrDaten(), arr() Dim arrHeader Dim sFile As String arrHeader = Array("Nr.", "Name", "loc_address", _ "loc_postal", "canonical_url", "loc_lat", "loc_lng", _ "cat_name", "stats_checkinscount", "stats_userscount ") ReDim arr(UBound(arrHeader)) With Application.FileDialog(msoFileDialogFilePicker) .Title = "Datei wählen" .AllowMultiSelect = False If .Show = -1 Then sFile = .SelectedItems(1) End If End With If sFile "" Then Set objDaten = CreateObject("Scripting.Dictionary") Open sFile For Input As #1 sTmp = Split(Input(LOF(1), 1), vbCrLf) Close #1 For i = 0 To UBound(sTmp) arrTmp = Split(sTmp(i), ":") If UBound(arrTmp) > 0 Then sItem = Trim(Replace(arrTmp(1), Chr(34), "")) If Len(arrTmp(1)) Then sItem = Left(sItem, Len(sItem) - 1) Select Case LCase(Trim(Replace(arrTmp(0), Chr(34), ""))) Case "id" bln = Not bln n = n - bln If bln Then ReDim arr(UBound(arrHeader)) Case "name" If bln Then arr(0) = n arr(1) = sItem Else arr(7) = sItem End If Case "address": arr(2) = sItem Case "postalcode": arr(3) = sItem Case "canonicalurl": arr(4) = sItem & Left(arrTmp(2), Len(arrTmp(2)) - 2) Case "lat": arr(5) = sItem Case "lng": arr(6) = sItem Case "checkinscount": arr(8) = sItem Case "userscount": arr(9) = sItem End Select objDaten(n) = arr End If End If Next objDaten(0) = arrHeader ReDim arrDaten(1 To objDaten.Count, 1 To UBound(arrHeader) + 1) For i = 0 To n arrTmp = objDaten(i) For j = 0 To UBound(arrHeader) arrDaten(i + 1, j + 1) = arrTmp(j) Next Next With Sheets(1) .Cells.Clear .Cells(1, 1).Resize(UBound(arrDaten), UBound(arrDaten, 2)) = arrDaten End With End If End Sub

...leider bin ich doch noch nicht fertig.
Jetzt habe ich einen ganz ähnlichen Ausdruck:
https://www.herber.de/bbs/user/85033.txt
Unten ist ein Auszug:
Wie man sieht, sind die Ergebnisse etwas länger. Die Formatierung bleibt gleich.
Ich habe Rudis makro für die erste Anfrage genommen und das Array auf 2 verkleinert (da ich nur noch den Namen und das Rating brauche.
Leider spuckt mir das Makro nur einen Teil der Ergebnisse, meist ohne Namen aus.
Ich sehe, dass das Makro das falsche "name" beim ersten Mal zieht - es landet gleich zwei "name" zu weit unten (in dieser Abfrage ist ein weiteres "name" eingezogen, so dass ich nur jedes dritte ziehen will.)
Eigentlich müsste es ja nur eine minimale Änderung sein, da die Deklarationen etc. gleich bleiben?
"totalResults": 98,
"groups": [
{
"type": "Recommended Places",
"items": [
{
"reasons": {
"count": 1,
"items": [
{
"type": "general",
"message": "This spot is popular"
}
]
},
"venue": {
"id": "4ade0cd3f964a520446921e3",
"name": "Theresienwiese",
"contact": {},
"location": {
"address": "Bavariaring",
"crossStreet": "Theresienhöhe",
"lat": 48.13166854919786,
"lng": 11.549849510192871,
"distance": 2412,
"postalCode": "80336",
"city": "München",
"country": "Germany",
"cc": "DE"
},
"canonicalUrl": "https://foursquare.com/v/theresienwiese/4ade0cd3f964a520446921e3",
"categories": [
{
"id": "4bf58dd8d48988d15f941735",
"name": "Field",
"pluralName": "Fields",
"shortName": "Field",
"icon": "https://foursquare.com/img/categories/parks_outdoors/default.png",
"parents": [
"Outdoors & Recreation"
],
"primary": true
}
],
"verified": false,
"stats": {
"checkinsCount": 5053,
"usersCount": 1802,
"tipCount": 18
},
"url": "http://de.wikipedia.org/wiki/theresienwiese",
"likes": {
"count": 29,
"groups": [
{
"type": "others",
"count": 29,
"items": []
}
],
"summary": "29 likes"
},
"like": false,
"rating": 9.18,
"beenHere": {
"count": 0,
"marked": false
},
"specials": [],
"photos": {
"count": 236,
"groups": []
},
"hereNow": {
"count": 1,
"groups": [
{
"type": "others",
"name": "Other people here",
"count": 1,
"items": []
}
]
}
},
"tips": [
{
"id": "4f495f09e4b09620886b9999",
"createdAt": 1330208521,
"text": "Come here during Oktoberfest!",
"canonicalUrl": "https://foursquare.com/item/4f495f09e4b09620886b9999",
"likes": {
"count": 0,
"groups": []
},
"logView": true,
"todo": {
"count": 4
},
"done": {
"count": 28
},
"user": {
"id": "22477478",
"firstName": "Visit Munich",
"gender": "none",
"photo": "https://is1.4sqi.net/userpix_thumbs/ZDDZMTIVCSSV32BM.png",
"type": "page",
"followers": {
"count": 2009,
"groups": []
},
"tips": {
"count": 20
},
"lists": {
"groups": [
{
"type": "created",
"count": 2,
"items": []
}
]
},
"homeCity": "München, Germany",
"bio": "",
"contact": {
"twitter": "visitmunich",
"facebook": "108378172646122"
}
}
}
],
"phrases": [
{
"phrase": "oktoberfest",
"sample": {
"entities": [
{
"indices": [
8,
19
],
"type": "keyPhrase"
}
],
"text": "... the Oktoberfest."
},
"count": 4
},
{
"phrase": "oktoberfest",
"sample": {
"entities": [
{
"indices": [
16,
27
],
"type": "keyPhrase"
}
],
"text": "... here during Oktoberfest!"
},
"count": 2
},
{
"phrase": "tradition",
"sample": {
"entities": [
{
"indices": [
16,
25
],
"type": "keyPhrase"
}
],
"text": "... im Festzelt Tradition nicht verpassen!"
},
"count": 1
}
],
"referralId": "e-0-4ade0cd3f964a520446921e3-0"
},
{
"reasons": {
"count": 1,
"items": [
{
"type": "general",
"message": "This spot is popular"
}
]
},
"venue": {
"id": "4ade0cd5f964a5204e6921e3",
"name": "Tierpark Hellabrunn",
"contact": {},
"location": {
"address": "Tierparkstr. 30",
"lat": 48.09969785289792,
MAKRO

Sub einlesen()
Dim sTmp, i As Long, j As Integer, n As Integer
Dim arrTmp, sItem As String, blnCat As Boolean
Dim objDaten As Object, arrDaten(), arr()
Dim arrHeader
Dim sFile As String
arrHeader = Array("Nr.", "Name", "rating")
ReDim arr(UBound(arrHeader))
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Datei wählen"
.AllowMultiSelect = False
If .Show = -1 Then
sFile = .SelectedItems(1)
End If
End With
If sFile  "" Then
Set objDaten = CreateObject("Scripting.Dictionary")
Open sFile For Input As #1
sTmp = Split(Input(LOF(1), 1), vbCrLf)
Close #1
Do
'erste ID suchen
arrTmp = Split(sTmp(i), ":")
If UBound(arrTmp) > 0 Then
If LCase(Trim(Replace(arrTmp(0), Chr(34), ""))) = "id" Then
Exit Do
End If
End If
i = i + 1
Loop
Do
arrTmp = Split(sTmp(i), ":")
If UBound(arrTmp) > 0 Then
sItem = Trim(Replace(arrTmp(1), Chr(34), ""))
If Len(arrTmp(1)) Then
sItem = Left(sItem, Len(sItem) - 1)
Select Case LCase(Trim(Replace(arrTmp(0), Chr(34), "")))
Case "categories": blnCat = True
Case "id"
n = n + 1 + blnCat
If Not blnCat Then ReDim arr(UBound(arrHeader))
Case "name"
If blnCat Then
arr(2) = sItem
blnCat = False
Else
arr(0) = n
arr(1) = sItem
End If
Case "rating": arr(2) = sItem
End Select
objDaten(n) = arr
End If
End If
i = i + 1
Loop Until i > UBound(sTmp)
objDaten(0) = arrHeader
ReDim arrDaten(1 To objDaten.Count, 1 To UBound(arrHeader) + 1)
For i = 0 To n
arrTmp = objDaten(i)
For j = 0 To UBound(arrHeader)
arrDaten(i + 1, j + 1) = arrTmp(j)
Next
Next
With Sheets(1)
.Cells.Clear
.Cells(1, 1).Resize(UBound(arrDaten), UBound(arrDaten, 2)) = arrDaten
End With
End If
End Sub

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Teile einer Text Datein in Excel

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread