Ce code met a jour un fichier Excel avec un fichier csv :
Sub CorrespTitres()
Set TSMBk = Workbooks.Open(Filename:="C:\Medialand\baseAscii\titres_ojd.csv" )
Set TSMSht = TSMBk.Worksheets(1)
Set CouplBk = Workbooks.Open(Filename:="C:\Medialand\baseAscii\support_bdd.csv" )
Set CouplSht = CouplBk.Worksheets(1)
'Suppression des Espaces dans Fichier Correspondance
NbLineCorresp = CorrespSht.Cells(65536, 1).End(xlUp).Row
For A = 2 To NbLineCorresp
For B = 1 To 5
CorrespSht.Cells(A, B) = Trim(CorrespSht.Cells(A, B))
Next B
Next A
'Tri Fichier Correspondance
CorrespSht.Cells.Sort Key1:=CorrespSht.Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'A/ SUPPORT_BDD.CSV
'Transformation CSV >> XLS
'1/ Rétablissement des Virgules
With CouplSht
NbLineCoupl = .Cells(65536, 2).End(xlUp).Row
If NbLineCoupl > 1 Then
For A = 1 To NbLineCoupl
If .Cells(A, 256).End(xlToLeft).Column > 1 Then
For B = 2 To .Cells(A, 256).End(xlToLeft).Column
.Cells(A, 1) = .Cells(A, 1) & "," & .Cells(A, B)
Next B
End If
Next A
Range(.Cells(1, 2), .Cells(NbLineCoupl, 256)).Clear
End If
'2/ Séparation des champs
Application.DisplayAlerts = False
.Columns(1).TextToColumns Destination:=Range("A1" ), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
(20, 1), Array(21, 1), Array(22, 1), Array(23, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = True
'MAJ Fichier Correspondance
NbLineCoupl = .Cells(65536, 1).End(xlUp).Row
NbLineCorresp = CorrespSht.Cells(65536, 1).End(xlUp).Row
For A = 1 To NbLineCoupl
'Cas Code TSM Numérique
If IsNumeric(.Cells(A, 3)) Then
'Cas Code TSM Présent dans Fichier Correspondance
If Not IsError(Application.Match(.Cells(A, 3), Range(CorrespSht.Cells(2, 2), CorrespSht.Cells(NbLineCorresp, 2)), 0)) Then
B = Range(CorrespSht.Cells(1, 2), CorrespSht.Cells(NbLineCorresp, 2)).Find(what:=Trim(.Cells(A, 3)), lookat:=xlWhole).Row
CorrespSht.Cells(B, 1) = Trim(.Cells(A, 1))
'Code TSM Absent
Else
CorrespSht.Cells(NbLineCorresp + 1, 2) = Trim(.Cells(A, 3))
CorrespSht.Cells(NbLineCorresp + 1, 1) = Trim(.Cells(A, 1))
NbLineCorresp = NbLineCorresp + 1
End If
'Autres Cas
Else
If Not IsError(Application.Match(Trim(.Cells(A, 3)), Range(CorrespSht.Cells(2, 2), CorrespSht.Cells(NbLineCorresp, 2)), 0)) Then
B = Range(CorrespSht.Cells(1, 2), CorrespSht.Cells(NbLineCorresp, 2)).Find(what:=Trim(.Cells(A, 3)), lookat:=xlWhole).Row
CorrespSht.Cells(B, 1) = Trim(.Cells(A, 1))
Else
CorrespSht.Cells(NbLineCorresp + 1, 2) = Trim(.Cells(A, 3))
CorrespSht.Cells(NbLineCorresp + 1, 1) = Trim(.Cells(A, 1))
NbLineCorresp = NbLineCorresp + 1
End If
End If
Next A
End With
'B/ TITRE_OJD.CSV
'Transformation CSV >> XLS
'1/ Rétablissement des Virgules
With TSMSht
NblineTSM = .Cells(65536, 1).End(xlUp).Row
If .Cells(65536, 2).End(xlUp).Row > 1 Then
For A = 2 To NblineTSM
If .Cells(A, 256).End(xlToLeft).Column > 1 Then
For B = 2 To .Cells(A, 256).End(xlToLeft).Column
.Cells(A, 1) = .Cells(A, 1) & "," & .Cells(A, B)
Next B
End If
Next A
Range(.Cells(1, 2), .Cells(NblineTSM, 256)).Clear
End If
'2/ Séparation des Champs
Application.DisplayAlerts = False
.Columns(1).TextToColumns Destination:=Range("A1" ), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = True
'MAJ Fichier Correspondance
For A = 1 To NblineTSM
If IsNumeric(.Cells(A, 2)) Then
If Not IsError(Application.Match(.Cells(A, 2), Range(CorrespSht.Cells(2, 2), CorrespSht.Cells(NbLineCorresp, 2)), 0)) Then
B = Range(CorrespSht.Cells(1, 2), CorrespSht.Cells(NbLineCorresp, 2)).Find(what:=Trim(.Cells(A, 2)), lookat:=xlWhole).Row
CorrespSht.Cells(B, 1) = Trim(.Cells(A, 1))
Else
CorrespSht.Cells(NbLineCorresp + 1, 2) = Trim(.Cells(A, 2))
CorrespSht.Cells(NbLineCorresp + 1, 1) = Trim(.Cells(A, 1))
NbLineCorresp = NbLineCorresp + 1
End If
Else
If Not IsError(Application.Match(Trim(.Cells(A, 2)), Range(CorrespSht.Cells(2, 2), CorrespSht.Cells(NbLineCorresp, 2)), 0)) Then
B = Range(CorrespSht.Cells(1, 2), CorrespSht.Cells(NbLineCorresp, 2)).Find(what:=Trim(.Cells(A, 2)), lookat:=xlWhole).Row
CorrespSht.Cells(B, 1) = Trim(.Cells(A, 1))
Else
If Len(Trim(.Cells(A, 2))) > 3 And Left(Trim(.Cells(A, 2)), 3) <> "WWW" And Left(Trim(.Cells(A, 2)), 4) <> "HSTV" _
And Left(Trim(.Cells(A, 2)), 4) <> "EPIQ" Or Len(Trim(.Cells(A, 2))) = 3 Then
CorrespSht.Cells(NbLineCorresp + 1, 2) = Trim(.Cells(A, 2))
CorrespSht.Cells(NbLineCorresp + 1, 1) = Trim(.Cells(A, 1))
NbLineCorresp = NbLineCorresp + 1
End If
End If
End If
Next A
End With
TSMBk.Close savechanges:=False
CouplBk.Close savechanges:=False
End Sub