XL 2016 verification du code

[Tresor1]

bonjour a tous ,

quelqu un pourrait il m aider avec ce code s il vous plait .il ya aucune mension d erreur lors de l excecution mais il n excecute pas ce qui est demander.merci


If Absender Like "SOCOS-C*;C/AOO*" Then
BereitsVorhanden = ExcelZeileBereitsVorhanden(originalArray, originalRowIndex, Dokument, Sachgebiet)
If BereitsVorhanden = True Then
Eintragen = False
End If
End If

If Eintragen = True Then
With Sheets("externe Dokumente")
freieZeile = Cells(Rows.Count, 1).End(xlUp).Row + 1
Call ExcelZellenFormatieren(freieZeile)
.Cells(freieZeile, 1).Value = Cells(freieZeile - 1, 1) + 1
.Cells(freieZeile, 4).Value = "siehe gültiges Dokument"
.Cells(freieZeile, 11).Value = Eingangsdatum
.Cells(freieZeile, 11).NumberFormat = "dd.mm.yy"
.Cells(freieZeile, 18).Value = originalArray(originalRowIndex, 9)
.Cells(freieZeile, 18).Interior.Color = ExcelZellenfarbeHinweis(originalArray(originalRowIndex, 9))
.Cells(freieZeile, 19).Value = originalArray(originalRowIndex, 2)
.Cells(freieZeile, 20).Value = Sachgebiet
.Cells(freieZeile, 3).Value = originalArray(originalRowIndex, 7)
.Cells(freieZeile, 5).Value = originalArray(originalRowIndex, 1)
.Cells(freieZeile, 5).NumberFormat = "dd.mm.yy"
.Hyperlinks.Add Anchor:=Cells(freieZeile, 2), Address:=originalArray(originalRowIndex, 4), TextToDisplay:=Dokument
End With
If Not originalRowIndex = UBound(originalArray) Then
If originalArray(originalRowIndex, 2) Like "VAW" And originalArray(originalRowIndex + 1, 2) Like "AN*" _
Or originalArray(originalRowIndex, 2) Like "BBL" And originalArray(originalRowIndex + 1, 2) Like "AN*" Then
Call ExcelGruppieren(originalArray, originalRowIndex, freieZeile)
End If
End If
End If
Next originalRowIndex
End Sub

 

[danielco]

Bonjour,

Il semble manquer le début... C'est put-être pour ça qu'il ne s'exécute pas ? Qu'est-ce qu'il est censé faire, le code ? Parce que, si on ne le sait pas et qu'il ne le fait pas...

Cordialement.

Daniel

 

[Tresor1]

c est juste une parite du code que j ai mis puisque c est a niveau qu il ya propleme le code est sense lire les document SOCOS-C*;C/AOO qui sont dans mon outlook et les ouvres dans Excel

 

[danielco]

Comme je te l'ai dit, il semble manquer le début du code.

Daniel

 

[Tresor1]

voici le debut

Sub MailSocos(textBody, Eingangsdatum, Absender)
'Es wird ein Array mit den Informationen aus der Socos E-Mail erstellt.

Dim Sachgebiet As String
Sachgebiet = SocosFindeSachgebiet(textBody)
Dim Anfangswort As String
Dim Endwort As String
Dim gekuerzterText As String
Anfangswort = "Hinweis"
Endwort = "Spalte"

'Textkörper aus der E-Mail wird gekürzt. (Nur die Tabelle in der Socos E-Mail ist wichtig)
gekuerzterText = KuerzeText(textBody, Anfangswort, Endwort)

'Unnötige Zeichen an Textanfang und -ende werden entfernt
gekuerzterText = SocosEntferneLeerzeichen(gekuerzterText)

If gekuerzterText Like "0" Then
Exit Sub
End If

Dim socosArray() As String

'Informationen aus der Tabelle werden in Array überführt.
'In diesem Schritt ist das socosArray 1:1 so augebaut, wie die Tabelle in der E-Mail
socosArray = SocosErstelleArray(gekuerzterText)

'Link wird aus erster Spalte entfernt, es bleibt nur noch das Dokument (Dokumentennummer) übrig
socosArray = SocosBearbeiteErsteSpalte(socosArray)

'Der Eintrag 'Titel' aus der Tabelle wird in zwei Spalten (Dokument und Titel) aufgeteilt
socosArray = SocosFuegeSpalteHinzu(socosArray)

'Es wird ein Array erstellt, dass alle relevanten Zeilennummern enthält
'Gibt es den gleichen Eintrag in mehreren Sprachen, wird nur der deutsche berücksichtigt
Dim WichtigeZeilenArray() As Integer
WichtigeZeilenArray = SocosFindeWichtigeZeilen(socosArray)

'Mit Hilfe der wichtigen Zeilen, werden aus dem socosArray die unwichtigen entfernt
socosArray = SocosEntferneUeberfluessigeZeilen(socosArray, WichtigeZeilenArray)

'Der Link wir angepasst, so dass er im weiteren Verlauf verwendet werden kann
socosArray = BearbeiteLink(socosArray)

'socosArray wird übergeben, um es in Excel einzutragen
Call ExcelEintragen(socosArray, Eingangsdatum, Absender, Sachgebiet)

End Sub

Function SocosFindeWichtigeZeilen(socosArray)
'Es wird ein Array erstellt, dass alle relevanten Zeilennummern enthält
'Gibt es den gleichen Eintrag in mehreren Sprachen, wird nur der deutsche berücksichtigt
Dim socosRows As Integer
Dim SocosCols As Integer
socosRows = UBound(socosArray)
SocosCols = UBound(socosArray, 2)
Dim targetArray() As Integer
Dim targetArrayLength As Integer
targetArrayLength = -1
Dim targetColIndex
Dim AnzahlGleicheZeilen
AnzahlGleicheZeilen = 1
Dim socosRowIndex As Integer
Dim SocosRowDeutsch As Integer

If socosRows > 0 Then
For socosRowIndex = 0 To (socosRows - 1)
If socosArray(socosRowIndex, 0) = socosArray(socosRowIndex + 1, 0) And socosArray(socosRowIndex, 9) = socosArray(socosRowIndex + 1, 9) Then
AnzahlGleicheZeilen = AnzahlGleicheZeilen + 1
'Sonderbedingung, wenn das Array Ende erreicht ist:
If socosRowIndex = socosRows - 1 Then
socosRowIndex = socosRowIndex + 1
SocosRowDeutsch = SocosFindeDeutsch(socosArray, socosRowIndex, AnzahlGleicheZeilen)
targetArrayLength = targetArrayLength + 1
ReDim Preserve targetArray(targetArrayLength)
targetArray(targetArrayLength) = SocosRowDeutsch
AnzahlGleicheZeilen = 1
End If
Else
targetArrayLength = targetArrayLength + 1
ReDim Preserve targetArray(targetArrayLength)
If AnzahlGleicheZeilen = 1 Then
targetArray(targetArrayLength) = socosRowIndex
Else
SocosRowDeutsch = SocosFindeDeutsch(socosArray, socosRowIndex, AnzahlGleicheZeilen)
targetArray(targetArrayLength) = SocosRowDeutsch
End If
AnzahlGleicheZeilen = 1
'Sonderbedingung, wenn das Array Ende erreicht ist:
If socosRowIndex = socosRows - 1 Then
targetArrayLength = targetArrayLength + 1
ReDim Preserve targetArray(targetArrayLength)
targetArray(targetArrayLength) = socosRowIndex + 1
End If
End If
Next socosRowIndex
Else
ReDim targetArray(0)
targetArray(0) = 0
End If

SocosFindeWichtigeZeilen = targetArray
End Function

Function SocosFindeDeutsch(socosArray, socosRowIndex, SocosRowAnzahl)
'In mehreren inhaltlich gleichen Zeilen wird die deutsche gesucht und deren Zeilennummer zurückgegeben
Dim DeutschIndex As Integer
DeutschIndex = socosRowIndex - SocosRowAnzahl + 1
Dim findeDeutschIndex As Integer

Dim Start As Integer
Dim Ende As Integer
Start = socosRowIndex - SocosRowAnzahl + 1
Ende = socosRowIndex

For findeDeutschIndex = Start To Ende

If socosArray(findeDeutschIndex, 5) Like "DE" Then
DeutschIndex = findeDeutschIndex
End If

Next findeDeutschIndex
SocosFindeDeutsch = DeutschIndex
End Function

Function SocosEntferneUeberfluessigeZeilen(socosArray, WichtigeZeilenArray)
'Zeilen, die mehrfach in verschiedenen Sprachen vorkommen, werden entfernt

Dim targetArray() As String
Dim targetRows As Integer
Dim targetCols As Integer
targetRows = UBound(WichtigeZeilenArray)
targetCols = UBound(socosArray, 2)
ReDim targetArray(targetRows, targetCols)
Dim targetRowIndex As Integer
Dim targetColIndex As Integer
For targetRowIndex = 0 To targetRows
For targetColIndex = 0 To targetCols
targetArray(targetRowIndex, targetColIndex) = socosArray(WichtigeZeilenArray(targetRowIndex), targetColIndex)
Next targetColIndex
Next targetRowIndex
SocosEntferneUeberfluessigeZeilen = targetArray
End Function

Sub ExcelEintragen(originalArray, Eingangsdatum, Absender, Sachgebiet)
'Die mit den Informationen bestückten Arrays werden in Excel eingetragen

Dim freieZeile As Long
Dim OriginalRows As Integer
OriginalRows = UBound(originalArray)
Dim originalRowIndex As Integer

For originalRowIndex = 0 To OriginalRows
'Wenn in Spalte 6 ein Eintrag vorhanden ist, wird dieser genommen, ansonsten der aus Spalte 0
Dim Dokument As String
If originalArray(originalRowIndex, 6) Like "" Then
Dokument = originalArray(originalRowIndex, 0)
Else
Dokument = originalArray(originalRowIndex, 6)
End If

'Zeile aus SocosArray wird nur in Excel eingetragen, wenn die Zeile nicht bereits in Excel vorhanden ist
'PS und CC werden immer eingetragen
Dim Eintragen As Boolean
Dim BereitsVorhanden As Boolean
Eintragen = True
'If Absender Like "C/AOO Regelungsdatenbank*" Then
If Absender Like "*SOCOS-C*;C/AOO*" Then
BereitsVorhanden = ExcelZeileBereitsVorhanden(originalArray, originalRowIndex, Dokument, Sachgebiet)
If BereitsVorhanden = True Then
Eintragen = False
End If
End If

 

[xUpsilon]

Je ne fais que passer mais pour rendre son code plus lisible, on hésite pas à utiliser les balises [ CODE=vb ] [ /CODE ]

 

[Tresor1]

Merci pour l info Upsilon

 

[danielco]

On dirait que çà se passe dans "ExcelZeileBereitsVorhanden" dont on n'a pas le code. Ou alors, la condition:

If Absender Like "*SOCOS-C*;C/AOO*" Then

n'est pas réalisée.

Daniel

 

[Tresor1]

Merci j ai resolu le probleme je n avais pas defini C/AOO