T
Temjeh
Guest
Rebonjour à tous
Peut-on maider a modifier ceci je voudrais aulieu d'ouvrir le Fichier qui porte le nom de input box et de coller les données il sélectionne a la place la Feuil nommé Trie et colle les lignes a la suite. Là il vérifie les données de Cell E mais j'aimerais les données de Cell I a la place
Merci:
Sub Recherche()
Dim TabTemp As Variant
Dim CL As Workbook
Dim L As Long
Dim i As Long
Dim C As Byte
Dim DestClas As String
Dim Chem As String
Dim Ouvert As Boolean
DestClas = InputBox(" *Entrer le nom des à ne pas faire à transférés*")
If DestClas = "" Then Exit Sub
'Mémoriser les lignes et "Toper" celles correspondant au nom recherché
With ThisWorkbook.Sheets("Tous")
L = .Range("E65536").End(xlUp).Row
TabTemp = .Range(.Cells(1, 1), .Cells(L, 9)).Value
For i = 1 To L
If UCase(.Cells(i, 5).Value) = UCase(DestClas) Then
TabTemp(i, 9) = "x"
End If
Next i
End With
'Activation ou ouverture du classeur "Nom Recherché"
DestClas = DestClas & ".xls"
'Est-il déjà ouvert ?
For Each CL In Workbooks
If CL.Name = DestClas Then
Ouvert = True
Workbooks(DestClas).Activate
Exit For
End If
Next CL
'Ouvrir le fichier
If Not Ouvert Then
On Error GoTo OuvreErreur
Chem = "C:\Program Files\Territoire 2004\Territoires\"
Workbooks.Open Chem & DestClas
On Error GoTo 0
End If
'"Coller" les informations utiles et supprimer les lignes dans le fichier source
With Workbooks(DestClas).Sheets("Tous")
For i = 1 To UBound(TabTemp, 1)
If TabTemp(i, 9) = "x" Then
L = .Range("E65536").End(xlUp).Row + 1
For C = 1 To 8
.Cells(L, C).Value = TabTemp(i, C)
Next C
End If
Next i
End With
'Ferme le fichier en le sauvegardant
Workbooks(DestClas).Close True
'Supprime les lignes concernées dans le fichier source
With ThisWorkbook.Sheets("Tous")
For i = UBound(TabTemp, 1) To 1 Step -1
If TabTemp(i, 9) = "x" Then
ThisWorkbook.Sheets("Tous").Rows(i).Delete
Range("A1").Activate
End If
Next i
End With
Exit Sub
OuvreErreur:
MsgBox "Fichier " & Chem & DestClas & " inexistant !"
Exit Sub
End Sub
Merci
A++
Temjeh
Peut-on maider a modifier ceci je voudrais aulieu d'ouvrir le Fichier qui porte le nom de input box et de coller les données il sélectionne a la place la Feuil nommé Trie et colle les lignes a la suite. Là il vérifie les données de Cell E mais j'aimerais les données de Cell I a la place
Merci:
Sub Recherche()
Dim TabTemp As Variant
Dim CL As Workbook
Dim L As Long
Dim i As Long
Dim C As Byte
Dim DestClas As String
Dim Chem As String
Dim Ouvert As Boolean
DestClas = InputBox(" *Entrer le nom des à ne pas faire à transférés*")
If DestClas = "" Then Exit Sub
'Mémoriser les lignes et "Toper" celles correspondant au nom recherché
With ThisWorkbook.Sheets("Tous")
L = .Range("E65536").End(xlUp).Row
TabTemp = .Range(.Cells(1, 1), .Cells(L, 9)).Value
For i = 1 To L
If UCase(.Cells(i, 5).Value) = UCase(DestClas) Then
TabTemp(i, 9) = "x"
End If
Next i
End With
'Activation ou ouverture du classeur "Nom Recherché"
DestClas = DestClas & ".xls"
'Est-il déjà ouvert ?
For Each CL In Workbooks
If CL.Name = DestClas Then
Ouvert = True
Workbooks(DestClas).Activate
Exit For
End If
Next CL
'Ouvrir le fichier
If Not Ouvert Then
On Error GoTo OuvreErreur
Chem = "C:\Program Files\Territoire 2004\Territoires\"
Workbooks.Open Chem & DestClas
On Error GoTo 0
End If
'"Coller" les informations utiles et supprimer les lignes dans le fichier source
With Workbooks(DestClas).Sheets("Tous")
For i = 1 To UBound(TabTemp, 1)
If TabTemp(i, 9) = "x" Then
L = .Range("E65536").End(xlUp).Row + 1
For C = 1 To 8
.Cells(L, C).Value = TabTemp(i, C)
Next C
End If
Next i
End With
'Ferme le fichier en le sauvegardant
Workbooks(DestClas).Close True
'Supprime les lignes concernées dans le fichier source
With ThisWorkbook.Sheets("Tous")
For i = UBound(TabTemp, 1) To 1 Step -1
If TabTemp(i, 9) = "x" Then
ThisWorkbook.Sheets("Tous").Rows(i).Delete
Range("A1").Activate
End If
Next i
End With
Exit Sub
OuvreErreur:
MsgBox "Fichier " & Chem & DestClas & " inexistant !"
Exit Sub
End Sub
Merci
A++
Temjeh