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

lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
473
AtTheOne
AtTheOne
E
  • Question
Microsoft 365 Excel VBA
Réponses
5
Affichages
275
Excellearning
E
D
  • Question
XL 2019 Message diffèrent en fonction état booléens
Réponses
3
Affichages
506
darkjedi
D
chaelie2015
  • Question
XL 2013 Réduire un code
Réponses
0
Affichages
459
chaelie2015
chaelie2015
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
607
crocrocro
C
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
411
guiyom
G
M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
301
Gégé-45550
Gégé-45550
S
  • Question
Microsoft 365 Clavier virtuel: SelectionChange, empêche la répétition
Réponses
3
Affichages
323
Simon 1234
S
chris6999
  • Question
Microsoft 365 Boucle VB pour supprimer les caractères spéciaux et numériques d'une chaîne
Réponses
5
Affichages
345
patricktoulon
patricktoulon
cathodique
  • Résolu(e)
XL 2010 Module de classe avec Dictionary
3 4 5
Réponses
66
Affichages
3 K
patricktoulon
patricktoulon

Membres actuellement en ligne

Aucun membre en ligne actuellement.
1 membres et 64 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
314 628
Messages
2 111 337
Membres
111 105
dernier inscrit
Joffrette