Recherche de plusieurs mots identiques dans plusieurs feuilles
cs_sammel
Messages postés
11
Statut
Membre
-
cs_sammel Messages postés 11 Statut Membre -
cs_sammel Messages postés 11 Statut Membre -
Bonjour à tous
Je suis débutant en VBA et je suis en train de créer un planning de Rendez-vous d'élèves et j'aimerais pouvoir imprimer leurs RDV sur une feuille à part (nommée impplaneleve) .
le planning est constitué de 52 feuilles (1 par semaine nommée sem, sem (1), sem (2)....) sur la premiere ligne se trouve la date et sur la première colonne l'heure, j'ai commencé un code ou j'arrive à trouver le premier nom et à copier sa date et son heure
voici mon code
si quelqu'un peut m'aiguiller SVP
D'avance merci
Je suis débutant en VBA et je suis en train de créer un planning de Rendez-vous d'élèves et j'aimerais pouvoir imprimer leurs RDV sur une feuille à part (nommée impplaneleve) .
le planning est constitué de 52 feuilles (1 par semaine nommée sem, sem (1), sem (2)....) sur la premiere ligne se trouve la date et sur la première colonne l'heure, j'ai commencé un code ou j'arrive à trouver le premier nom et à copier sa date et son heure
voici mon code
je pense que pour trouver tous les autres nom identiques sur la feuille et sur les 51 autres feuilles il va falloir faire une boucle mais je ne sais pas trop comment
Dim celluletrouvee As Range
Dim ligne As Integer
Dim col As Integer
Dim Fnom As Worksheet
Dim FS1 As Worksheet
Dim FS2 As Worksheet
Dim FS3 As Worksheet
Set Fnom = Sheets("impplaneleve")
Set FS1 = Sheets("Sem")
Set FS2 = Sheets("Sem (2)")
Set FS3 = Sheets("Sem (3)")
Fnom.Select
nom = Range("B1").Value
Range("A4:B50").Select
Selection.ClearContents
FS1.Select
Set celluletrouvee = Range("B3:Z11").Find(nom, LookAt:=xlWhole)
If celluletrouvee Is Nothing Then
MsgBox ("pas trouvé")
Else
ligne = celluletrouvee.Row
col = celluletrouvee.Column
Cells(ligne - ligne + 1, col).Select
Selection.Copy
Fnom.Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
FS1.Select
Cells(ligne, col - col + 1).Select
Selection.Copy
Fnom.Select
Range("B4").Select
ActiveSheet.Paste
End If
End Sub
si quelqu'un peut m'aiguiller SVP
D'avance merci
1 réponse
-
J'ai encore modifier le code mais ça ne fonctionne pas
Sub Planning()
Dim nom As String
Dim entcol As String
Dim entlig As String
Dim donrenvoi As String
Dim lig As Integer
Dim col As Integer
Dim ligne As Integer
Dim colonne As Integer
Dim celluletrouvee As Range
Dim Fnom As Worksheet
Dim numero As Integer
numero = 4
Set Fnom = Sheets("impplaneleve")
Fnom.Select
nom = Range("B1").Value
Range("A4:C50").Select
Selection.ClearContents
For Each ws In Worksheets
If ws.Name <> "impplaneleve" Then
With ws
Set celluletrouvee = Range("B3:Z11").Find(nom, LookAt:=xlWhole)
derl = .Cells(12, 26).End(xlUp).Row
For i = 1 To derl
If celluletrouvee Is Nothing Then
MsgBox ("Terminé")
Else
lig = celluletrouvee.Row
ligne = celluletrouvee.Row - celluletrouvee.Row + 1
colonne = celluletrouvee.Column - celluletrouvee.Column + 1
End If
If celluletrouvee.Column <= 6 Then
col = celluletrouvee.Column - celluletrouvee.Column + 2
ElseIf celluletrouvee.Column <= 11 Then
col = celluletrouvee.Column - celluletrouvee.Column + 7
ElseIf celluletrouvee.Column <= 16 Then
col = celluletrouvee.Column - celluletrouvee.Column + 12
ElseIf celluletrouvee.Column <= 21 Then
col = celluletrouvee.Column - celluletrouvee.Column + 17
Else
col = celluletrouvee.Column - celluletrouvee.Column + 22
End If
entcol = Cells(ligne, col).Value
entlig = Cells(lig, colonne).Value
donrenvoi = entcol & " à " & entlig
Call RDV(donrenvoi)
Next i
End With
End If
End Sub
Sub RDV(donrenvoi)
With Sheets("impplaneleve")
Cells(numero, 1).Select
Selection.Value = donrenvoi
numero = numero + 1
Set celluletrouvee = Cells.FindNext(celluletrouvee)
End With
End Sub
senmel est actuellement connecté Envoyer un message privé Modifier/Supprimer le message
Please HELP!!!</signature>
<signature>sammel.
