Rép de post pour macro

[Temjeh]

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++

 

[EricS]

Bonjour,


pour observer la colonne I change E en I dans la ligne ci-dessous

L = .Range("E65536").End(xlUp).Row

pour la copie de A à I au lieu de A à H, à priori, mettre 9 au lieu de 8 dans

For C = 1 To 8

A vérifier, A+

Eric

 

[Temjeh]

Merci pour ton aide Erics

Pour le remplacement à 3 ou 4 place ca ne plante pas mais il ouvre mon fichier (= inputBox) et il le referme cut tout sauf la ranger i qu'il met un x à la place.. Ptêtre il me manque encore une petite modification.

Je sais que c'est pas facile sans L'essayé mais étant donné qu'il se réfère à des données de C:\Program Files\Territoire 2004\Territoires\ c'est plus dur de mettre un fichier en zip pour démo.

Merci et A++

Temjeh

Le voici modifié:

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("I65536").End(xlUp).Row
TabTemp = .Range(.Cells(1, 1), .Cells(L, 9)).Value
For i = 1 To L
If UCase(.Cells(i, 9).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("I65536").End(xlUp).Row + 1
For C = 1 To 9
.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

 

[EricS]

RE

c'est vrai que travailler en aveugle n'est pas le plus simple

a priori, la colonne i (9) contient des noms que l'on compare à celui que tu entres par l'inputbox
est-ce vrai ?

je suppose que tu veux en fait conserver cette colonne. Si c'est le cas essaie de remplacer 9 par 10 dans les lignes suivantes :

TabTemp = .Range(.Cells(1, 1), .Cells(L, 9)).Value

TabTemp(i, 9) = "x"

If TabTemp(i, 9) = "x" Then

For C = 1 To 9

If TabTemp(i, 9) = "x" Then

A+
Eric

 

[Temjeh]

Merci beaucoup j'ai prit tes deux rep et je les ai jumelées mais sans bug mais copiant rien,,,j'ai donc remarqué aussi qu'il fallait la cell a changer aussi....If UCase(.Cells(i, 9).Value) = UCase(DestClas) Then 5 pour 9

Voici la bête modifier:

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("I65536").End(xlUp).Row
TabTemp = .Range(.Cells(1, 1), .Cells(L, 10)).Value
For i = 1 To L
If UCase(.Cells(i, 9).Value) = UCase(DestClas) Then
TabTemp(i, 10) = "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, 10) = "x" Then
L = .Range("I65536").End(xlUp).Row + 1
For C = 1 To 10
.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, 10) = "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 beaucoup EricS

Temjeh

A+++