VBA Répétition

S

samanall

XLDnaute Nouveau
bonjour a toute et a tous
je travail pour une societe allemande et je dois écrire un programme qui me permettra de me connecter a un webserveur(webservice), pour ensuite recuperer des infos.
j'ai reussi a écrire le programme en question mais le probleme c'est que la macro dois se répéter sur les ligne suivante. est ce que qqn pourrai m'aider svp?
voici la macro et j'ai aussi joint le fichier:

Type dsoinfo
name As String
regelzone As String
End Type
Dim dso As dsoinfo
Public Function Abfrage(plz As String, ort As String) As Variant
Abfrage = plz
'Dim ort As String
' ort = getOrt(plz)
'If ort = "" Then
' MsgBox "Kein Ort zu PLZ gefunden!", , "Achtung"
' Exit Function
'End If
Dim dso As String
dso = getDSO(plz, ort)
If dso = "" Then
MsgBox "Fehler Webservice!", , "Achtung"
Exit Function
End If
Call getEntgelt(plz, dso)
End Function
Private Function getOrt(plz As String) As String
Dim s As New NotesSession
If s Is Nothing Then
getOrt = ""
MsgBox "Notes Fehler!", , "Achtung"
Exit Function
End If
Call s.Initialize
Dim targetdb As NotesDatabase
Set targetdb = s.GetDatabase("Duisburg6/PCC", "get\wsr.nsf", False)
If Not targetdb.IsOpen Then
MsgBox "Webservice nicht erreichbar!", , "Achtung"
getOrt = ""
Exit Function
End If
Dim RQdoc As NotesDocument
Set RQdoc = targetdb.CreateDocument
Call RQdoc.ReplaceItemValue("Form", "Request")
Dim varTmp As Variant
Dim varTmp2 As Variant
varTmp = s.Evaluate("@DocumentUniqueID", RQdoc)
varTmp2 = s.Evaluate("@Unique", RQdoc)
Call RQdoc.ReplaceItemValue("RQID", "RQ" & varTmp2(0) & "/" & varTmp(0))
Call RQdoc.ReplaceItemValue("Param.AbnahmePLZ", plz)
Call RQdoc.ReplaceItemValue("Param.Date", CStr(Date))
Call RQdoc.ReplaceItemValue("Param.Type", "Ort")
Call RQdoc.ReplaceItemValue("SaveOptions", "1")
Call RQdoc.ComputeWithForm(False, False)
Call RQdoc.Save(True, False)
Dim agent As NotesAgent
Set agent = targetdb.GetAgent("Get.Ortsservice")
Call agent.RunOnServer(RQdoc.NoteID)
Dim rsview As NotesView
Set rsview = targetdb.GetView("Lookup.Result.RSID")
Dim RSdoc As NotesDocument
Call rsview.Refresh
Set RSdoc = rsview.GetDocumentByKey(RQdoc.GetItemValue("RQID"), True)
If Not RSdoc Is Nothing Then
Dim maske As New UserForm1
For Each orte In RSdoc.GetItemValue("Result.AbnahmeOrt")
maske.ComboBox1.AddItem (orte)
'Ort = Ort & orte & ","
Next
maske.ComboBox1.ListIndex = 0
maske.Show
getOrt = CStr(maske.ComboBox1.Value)
Else
MsgBox "Kein Result!", , "Achtung"
getOrt = ""
End If
End Function
Private Function getDSO(plz As String, ort As String) As String
Dim s As New NotesSession
If s Is Nothing Then
getDSO = ""
MsgBox "Notes Fehler!", , "Achtung"
Exit Function
End If
Call s.Initialize
Dim targetdb As NotesDatabase
Set targetdb = s.GetDatabase("Duisburg6/PCC", "get\wsr.nsf", False)
If Not targetdb.IsOpen Then
MsgBox "Webservice nicht erreichbar!", , "Achtung"
getDSO = ""
Exit Function
End If
Dim RQdoc As NotesDocument
Set RQdoc = targetdb.CreateDocument
Call RQdoc.ReplaceItemValue("Form", "Request")
Dim varTmp As Variant
Dim varTmp2 As Variant
varTmp = s.Evaluate("@DocumentUniqueID", RQdoc)
varTmp2 = s.Evaluate("@Unique", RQdoc)
Call RQdoc.ReplaceItemValue("RQID", "RQ" & varTmp2(0) & "/" & varTmp(0))
Call RQdoc.ReplaceItemValue("Param.AbnahmePLZ", plz)
Call RQdoc.ReplaceItemValue("Param.AbnahmeOrt", ort)
Call RQdoc.ReplaceItemValue("Param.Date", CStr(Date))
Call RQdoc.ReplaceItemValue("Param.Type", "DSO")
Call RQdoc.ReplaceItemValue("SaveOptions", "1")
Call RQdoc.ComputeWithForm(False, False)
Call RQdoc.Save(True, False)
Dim agent As NotesAgent
Set agent = targetdb.GetAgent("Get.Ortsservice")
Call agent.RunOnServer(RQdoc.NoteID)
Dim rsview As NotesView
Set rsview = targetdb.GetView("Lookup.Result.RSID")
Dim RSdoc As NotesDocument
Call rsview.Refresh
Set RSdoc = rsview.GetDocumentByKey(RQdoc.GetItemValue("RQID"), True)
If Not RSdoc Is Nothing Then
If RSdoc.GetItemValue("Result.Success")(0) = "True" Then
If UBound(RSdoc.GetItemValue("Result.name")) > 0 Then
Dim maske As New UserForm1
For Each name In RSdoc.GetItemValue("Result.name")
maske.ComboBox1.AddItem (name)
Next
maske.ComboBox1.ListIndex = 0
maske.Show
chosen = maske.ComboBox1.Value
Dim i As Integer

For i = 0 To UBound(RSdoc.GetItemValue("Result.name"))
If RSdoc.GetItemValue("Result.name")(i) = chosen Then
With ThisWorkbook.Worksheets(1)
'ort
.Range("E7") = ort

'Netzbetreiber
.Range("F7") = CStr(RSdoc.GetItemValue("Result.name")(i))
'Regelzone
.Range("G7") = CStr(RSdoc.GetItemValue("Result.regelzone")(i))
getDSO = CStr(RSdoc.GetItemValue("Result.vdewid")(i))
End With
Exit For
End If
Next
Else
With ThisWorkbook.Worksheets(1)
.Range("E7") = ort
.Range("F7") = CStr(RSdoc.GetItemValue("Result.name")(0))
.Range("G7") = CStr(RSdoc.GetItemValue("Result.regelzone")(0))
getDSO = CStr(RSdoc.GetItemValue("Result.vdewid")(0))
End With
End If
Else
MsgBox "Netzbetreiber konnte nicht gefunden werden. Bitte überprüfen Sie die Kombination PLZ + Ort.", , "Fehler"
getDSO = ""
Exit Function
End If
Else
MsgBox "Kein Result!", , "Achtung"
getDSO = ""
End If
End Function
Private Sub getEntgelt(plz As String, dso As String)
Dim s As New NotesSession
If s Is Nothing Then
MsgBox "Notes Fehler!", , "Achtung"
Exit Sub
End If
Call s.Initialize
Dim targetdb As NotesDatabase
Set targetdb = s.GetDatabase("Duisburg6/PCC", "get\wsr.nsf", False)
If Not targetdb.IsOpen Then
MsgBox "Webservice nicht erreichbar!", , "Achtung"
Exit Sub
End If
Dim RQdoc As NotesDocument
Set RQdoc = targetdb.CreateDocument
Call RQdoc.ReplaceItemValue("Form", "Request")
Dim varTmp As Variant
Dim varTmp2 As Variant
varTmp = s.Evaluate("@DocumentUniqueID", RQdoc)
varTmp2 = s.Evaluate("@Unique", RQdoc)
Call RQdoc.ReplaceItemValue("RQID", "RQ" & varTmp2(0) & "/" & varTmp(0))
'Leistung


If ThisWorkbook.Worksheets(1).Range("P7").Value = "" Then
Call RQdoc.ReplaceItemValue("Param.Leistung", 0)


Else
Call RQdoc.ReplaceItemValue("Param.Leistung", ThisWorkbook.Worksheets(1).Range("P7").Value)

End If


Call RQdoc.ReplaceItemValue("Param.PLZ", plz)
Call RQdoc.ReplaceItemValue("Param.Jahresgesamtverbrauch", ThisWorkbook.Worksheets(1).Range("O7").Value)
Call RQdoc.ReplaceItemValue("Param.Date", CStr(ThisWorkbook.Worksheets(1).Range("J7").Value))

If ThisWorkbook.Worksheets(1).Range("L7").Value = "NSP ohne LM" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E06")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E06")
End If
If ThisWorkbook.Worksheets(1).Range("L7").Value = "NSP mit LM" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E06")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E06")
End If
If ThisWorkbook.Worksheets(1).Range("L7").Value = "MSP" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E05")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E05")
End If
If ThisWorkbook.Worksheets(1).Range("L7").Value = "MSU" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E09")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E06")
End If
If ThisWorkbook.Worksheets(1).Range("L7").Value = "MS/NS" Then
Call RQdoc.ReplaceItemValue("Param.spannungsebenemessung", "E05")
Call RQdoc.ReplaceItemValue("Param.spannungsebeneentnahme", "E06")
End If
Call RQdoc.ReplaceItemValue("Param.Type", "Entgelt")
Call RQdoc.ReplaceItemValue("Param.DSONr", dso)
Call RQdoc.ReplaceItemValue("SaveOptions", "1")
Call RQdoc.ComputeWithForm(False, False)
Call RQdoc.Save(True, False)
Dim agent As NotesAgent
Set agent = targetdb.GetAgent("Get.Stromservice")
Call agent.RunOnServer(RQdoc.NoteID)
Dim rsview As NotesView
Set rsview = targetdb.GetView("Lookup.Result.RSID")
Dim RSdoc As NotesDocument
Call rsview.Refresh
Set RSdoc = rsview.GetDocumentByKey(RQdoc.GetItemValue("RQID"), True)
If Not RSdoc Is Nothing Then
If RSdoc.HasItem("Result.Error") Then
MsgBox "Fehler: " & RSdoc.GetItemValue("Result.Error")(0), , "Achtung"
Exit Sub
End If
With ThisWorkbook.Worksheets(1)
'Arbeitspreis
.Range("Y7") = CDbl(Replace(RSdoc.GetItemValue("Result.Wirkarbeit")(0), ".", ",")) * 100 / CDbl(ThisWorkbook.Worksheets(1).Range("O7").Value)
.Range("X7") = CDbl(Replace(RSdoc.GetItemValue("Result.Wirkarbeit")(0), ".", ",")) * 100 / CDbl(ThisWorkbook.Worksheets(1).Range("O7").Value)
If CDbl(ThisWorkbook.Worksheets(1).Range("P7").Value) > 0 Then
'Leistungspreis
.Range("W7") = CDbl(Replace(RSdoc.GetItemValue("Result.Leistung")(0), ".", ",")) / CDbl(ThisWorkbook.Worksheets(1).Range("P7").Value)
End If
'Messkosten
.Range("AA7") = CDbl(Replace(RSdoc.GetItemValue("Result.entgelt_zaehlerpreis_ablesung")(0), ".", ",")) + CDbl(Replace(RSdoc.GetItemValue("Result.entgelt_fuer_abrechnung")(0), ".", ","))
'Grundpreis
End With
Else
MsgBox "Kein Result!", , "Achtung"
End If
Exit Sub
End Sub
 

Pièces jointes

  • Kalkulation_Strom_test.xlsm
    111.9 KB · Affichages: 80
Trier par date Trier par votes

Discussions similaires

chaelie2015
  • Question
XL 2013 Réduire un code
Réponses
0
Affichages
251
chaelie2015
chaelie2015
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
371
crocrocro
C
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
232
guiyom
G
Regueiro
  • Question
Microsoft 365 Format Nombre Combobox dans Feuille
Réponses
3
Affichages
167
fanch55
fanch55
O
  • Question
XL 2019 Je veux afficher mes données dans ma Listbox1 avec l'entete de ma Base donnée et fait la recherche sans que cela derange l'entete.
Réponses
6
Affichages
460
ChTi160
ChTi160
E
  • Question
XL 2013 vba excel
Réponses
6
Affichages
248
sylvanu
sylvanu
A
  • Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
124
Phil69970
Phil69970
C
  • Résolu(e)
XL 2021 Alimenter Listbox si colonne 3 contient un mot précis
Réponses
5
Affichages
244
Claudinedu13
C
V
  • Question
XL 2021 Upload fichier depuis Bureau
Réponses
7
Affichages
260
vmax67
V
B
  • Résolu(e)
Microsoft 365 Besoin d'aide pour faire fonctionner 2 codes VBA ensemble
Réponses
2
Affichages
145
BenExcel
B

Membres actuellement en ligne

6 membres et 81 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 305
Messages
2 087 083
Membres
103 458
dernier inscrit
Vulgaris workshop