Option Explicit
Sub GetGidPacTxT()
Dim BD As Worksheet, UM As Worksheet, InitRowUM As Long, LRowBD As Long, x As Long, Txt$, y As Integer, Pos As Integer, PAC$
Dim FindPAC As Integer, Deb As Integer, S, V, gidValue$, gidPart$, P
Dim A As Date, B$, C$, D$, E$, F$, G$, H$, I As Double
SupprimerDonneesUM
Set BD = ThisWorkbook.Sheets("BD")
Set UM = ThisWorkbook.Sheets("UM")
InitRowUM = 10
LRowBD = BD.Cells(Rows.Count, 1).End(xlUp).Row
' Application.ScreenUpdating = False
For x = 2 To LRowBD
Txt = BD.Cells(x, "B").Value
FindPAC = InStr(Txt, "+PAC+")
A = BD.Cells(x, "C").Value: B = BD.Cells(x, "A").Value: C = BD.Cells(x, "E").Value: D = BD.Cells(x, "F").Value: E = BD.Cells(x, "G").Value
F = BD.Cells(x, "H").Value: G = BD.Cells(x, "I").Value: H = BD.Cells(x, "J").Value: I = BD.Cells(x, "K").Value
If FindPAC = 0 Then
ReDim V(1 To 1, 1 To 9)
V(1, 1) = A: V(1, 2) = B: V(1, 3) = C: V(1, 4) = D: V(1, 5) = E: V(1, 6) = F: V(1, 7) = G: V(1, 8) = H: V(1, 9) = I
UM.Cells(InitRowUM, 1).Resize(UBound(V), UBound(V, 2)).Value = V
InitRowUM = InitRowUM + 1
Else
Deb = InStrRev(Txt, "GID++", FindPAC)
S = Mid(Txt, Deb)
S = Split(S, "GID++")
ReDim V(1 To UBound(S), 1 To 15)
For y = 1 To UBound(S)
Pos = InStr(S(y), ":"): gidValue = Mid(S(y), 1, Pos - 1): gidPart = Mid(S(y), Pos + 1, 2)
Pos = InStr(S(y), "+PAC+") + 5: PAC = Mid(S(y), Pos): P = Split(PAC, ":")
ReDim Preserve P(0 To 2)
V(y, 1) = A: V(y, 2) = B: V(y, 3) = C: V(y, 4) = D: V(y, 5) = E: V(y, 6) = F: V(y, 7) = G: V(y, 8) = H: V(y, 9) = I
V(y, 11) = P(0): V(y, 12) = P(1): V(y, 13) = P(2): V(y, 14) = gidValue: V(y, 15) = gidPart
Next
UM.Cells(InitRowUM, 1).Resize(UBound(V), UBound(V, 2)).Value = V
InitRowUM = InitRowUM + UBound(V)
End If
Next
' Application.ScreenUpdating = True
End Sub
Sub SupprimerDonneesUM()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("UM")
With ws
.Rows("10:" & .Rows.Count).Delete
End With
End Sub