T
Temjeh
Guest
Bonjour à tous
Étant donné que je n'ai recu aucune réponse antérieur pour ce trouble je vous réécrit au cas ou...
Je veut juste changer dans cette macro
voit si valeur de inputBox est dans Col i au lieu de Col E et cut les col A à i au lieu de A à H
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 infiniment
Temjeh
A++
Étant donné que je n'ai recu aucune réponse antérieur pour ce trouble je vous réécrit au cas ou...
Je veut juste changer dans cette macro
voit si valeur de inputBox est dans Col i au lieu de Col E et cut les col A à i au lieu de A à H
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 infiniment
Temjeh
A++