Option Explicit
Sub travdemande()
Dim i As Long
Dim j As Long
Dim data1 As Variant
Dim cellule As Range
Dim plage As Range
Dim nomfeuille1 As String
Dim col1 As String
Dim classeur1 As String
Dim lidep1 As Long
Dim dl1 As Long
Dim data2 As String
Dim trouve As Boolean
Dim lidep2 As Long
Dim nomfeuille2 As String
Dim col2 As String
Dim dl2 As Long
'************ a modifier **********
nomfeuille1 = "Feuil1"
col1 = "a"
lidep1 = 1
'************* fin de modif ***********
With Sheets(nomfeuille1)
dl1 = Sheets(nomfeuille1).Range(col1 & "65536").End(xlUp).Row + 2
Set plage = .Range(col1 & lidep1 & ":" & col1 & .Range(col1 & "65536").End(xlUp).Row)
End With
'************ a modifier **********
nomfeuille2 = "Feuil2"
col2 = "a"
lidep2 = 1
'************* fin de modif ***********
dl2 = Sheets(nomfeuille2).Range(col2 & "65536").End(xlUp).Row + 1
With Sheets(nomfeuille2)
'************ a modifier **********
' la variable contient les données que l'on désire inclure dans la feuille excel
' Il est possible de faire un remappage des colonnes
' la première valeur correspond à la colonne 1 et sert de séparateur de ligne
'
data1 = VBA.Array("Server", "Pathname", "DbStoragePath", "DbVolumeName", "Title", "Categories", _
"ReplicaID", "DbType", "RepDisabled", "RepRecSumm", "RepSendDel", "RepSendTitleAndCatalog", _
"RepPriority", "RepRemoveOld", "RepRemoveInterval", "DbCreationDate", "DbTemplateName", _
"DbListInCatalog", "DbShowInDialog", "DbFullTextIndexed", "DbMultiIndexing", "DesignerList", _
"EditorList", "DepositorList", "DbInheritTemplateName", "DbAdminServer", "DbAdminServerNames", _
"ManagerList", "NoAccessList", "DbNumDesignDocuments", "DbSize")
'************* fin de modif ***********
For i = LBound(data1) To UBound(data1)
.Cells(1, i + 1) = data1(i)
Next i
For Each cellule In plage
trouve = False
If cellule.Value <> "" Then
j = InStr(1, cellule.Value, ":")
If j > 0 Then
data2 = Left(Trim(cellule.Value), j - 1)
If Len(data2) + 1 < Len(Trim(cellule.Value)) Then ' si pas de données
For i = LBound(data1) To UBound(data1)
If data2 = data1(i) Then
trouve = True
Exit For
End If
Next i
If trouve = True Then
If data2 = data1(LBound(data1)) Then dl2 = Sheets(nomfeuille2).Range(col2 & "65536").End(xlUp).Row + 1
.Cells(dl2, i + 1) = Trim(Mid(cellule.Value, j + 1, 250))
End If
End If
End If
End If
Next cellule
End With
End Sub
JP