gebraucht preis abfrage amazon
01.12.2017 05:10:46
jbender
ich habe folgendes problem und bin so langsam am verzweifeln.....
ich habe knapp 13.000 bücher aus einem nachlass aus meiner familie übernommen.
1500 bücher habe ich bis jetzt eingelagert und mit der software "BooKcook Pro" mir die dazugehörigen infos rausgesucht.
Leider sucht mit das Programm keine Preise automatisch mit raus und trägt sie ein wie ich es anfangs gedacht hatte.
Für mich ist auch nur wichtig eine ungefähre vorstellung zu bekommen von jedem buch was es gebraucht überhaupt noch wert ist, um nicht unnötig platz im regal zu verschwenden mit büchern die unter 5 euro gehandelt werden.
ich habe mich schon doof gegoogelt um eine lösung zu finden wie ich in meiner excel tabelle zur jeder isbn automatisch einen gebraucht preis suchen und eintragen lassen kann.
ich bin hier im foren archiv auf eine lösung von franz gestossen die aber leider nicht mehr richtig funktioniert.
hier einmal der link zum beitrag:
https://www.herber.de/forum/archiv/1376to1380/1377946_ExcelVBA_Webabfrage.html#1377946
hier einmal der link zum beitrag:
https://www.herber.de/forum/archiv/1376to1380/1377946_ExcelVBA_Webabfrage.html#1377946
und hier einmal das makro zu seiner datei
Sub webabfrage()
Dim i As Long, Zeile As Long
Dim Itext As String
Dim MyUrl As String
Dim MyISBN As String
Dim IEApp As Object
Dim IEDocument As Object
Dim strTitel As String, strAutor As String, strPreis, varDatum, varZeile
On Error GoTo Fehler
varZeile = Application.InputBox("Startzeile für Einlesen der Links", _
"Amazon-Links auswerten", ActiveCell.Row, Type:=1)
If varZeile 0 Then
Itext = Left(Itext, InStr(1, Itext, "gebraucht (") - 1)
strPreis = Trim(Mid(Itext, InStrRev(Itext, "EUR")))
Cells(Zeile, 8) = strPreis
End If
If InStr(1, Itext, "neu (") > 0 Then
Itext = Left(Itext, InStr(1, Itext, "neu (") - 1)
strPreis = Trim(Mid(Itext, InStrRev(Itext, "EUR")))
Cells(Zeile, 7) = strPreis
End If
If Cells(Zeile, 7) = "" And Cells(Zeile, 8) = "" Then
Cells(Zeile, 7) = "keine Preisinfo"
End If
'Text vor letztem "EUR " abschneiden
If InStrRev(Itext, "EUR ") > 0 Then
Itext = Left(Itext, InStrRev(Itext, "EUR ") - 1)
End If
'Text nach letzter ")" abschneiden
If InStrRev(Itext, ")") > 0 Then
Itext = Left(Itext, InStrRev(Itext, ")"))
End If
'Zeilenschaltungen durch Leerzeichen ersetzen
Itext = Trim(Replace(Itext, Chr(10), " "))
Itext = Trim(Replace(Itext, Chr(13), " "))
'doppelte Leerzeichen durch einzelnes Leerzeichen ersetzen
Itext = Trim(Replace(Itext, " ", " "))
strTitel = ""
strAutor = ""
varDatum = ""
'Prüfen, ob " von " im Text vorhanden - trennt Titel und Autor
If InStrRev(Itext, " von ") > 0 Then
strTitel = Left(Itext, InStrRev(Itext, " von ") - 1)
strTitel = Trim(Mid(strTitel, Len(MyISBN) + 3))
strAutor = Mid(Itext, InStrRev(Itext, " von ") + 5)
strAutor = Trim(Left(strAutor, InStrRev(strAutor, "(") - 1))
Else
'Titel ohne Autor
strTitel = Itext
strTitel = Trim(Mid(strTitel, Len(MyISBN) + 3))
End If
'Prüfen ob "(" im Text - danach beginnt meistens Erscheinungsdatum
If InStrRev(Itext, "(") > 0 Then
varDatum = Trim(Mid(Itext, InStrRev(Itext, "(") + 1))
varDatum = Replace(varDatum, ")", "")
End If
Resume01:
Cells(Zeile, 5).Value = strTitel
Cells(Zeile, 4).Value = strAutor
Cells(Zeile, 6).Value = varDatum
Next Zeile
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 5 'Fehler bei der Instr-Suche bzw. der Mid- oder Left-Funktion
Resume Resume01
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Kann mir jemand dieses Makro so anpassen das es wieder funktioniert und mir die preise wieder ordentlich einträgt?