XL 2010 Sélection de lignes entre deux cellules

[tallia64]

Bonjour à tout le forum,

Je cherche à créer une macro pour sélectionner des lignes avec deux cellules d'une valeur distincte exemple :

la cellule A1= "DEPART" et la cellule A6 ="ARRIVEE" .
Sélection des lignes de A1 à A A6 et faire une boucle avec la macro à chaque fois qu'apparait ces deux valeurs dans ma feuil Excel et récupérer les lignes.
Cette sélection me permettrait de coller ces lignes vers un autre classeur Excel ou onglet.
Je vous remercie d'avance pour votre aide.
Bonne journée.

Tallia

 

[vgendron]

Bonjour

il faudrait un fichier en guise d'exemple pour clarifier ton besoin

la cellule A1= "DEPART" et la cellule A6 ="ARRIVEE" .
Sélection des lignes de A1 à A A6

ca pourrait donner: Range("A1:A6").select

faire une boucle avec la macro à chaque fois qu'apparait ces deux valeurs dans ma feuil Excel et récupérer les lignes.

???

 

[tallia64]

Bonsoir vgendron,

Je vous remercie pour ton aide. Voici un petit fichier. En fait dès que des cellules contiennent DEPART et ARRIVEE il faudrait que la macro me sélectionne toutes les lignes afin que je puisse les intégrer dans un nouveau classeur et un onglet différent pour chaque demande.

Tallia

 

[belkacem_64]

Salut
essai

 

[job75]

Bonsoir tallia64, vgendron, belkacem_64,

Voyez le fichier joint et cette macro dans la code de la 1ère feuille :

Private Sub CommandButton1_Click()
Dim i&, c As Range, deb As Range, nom$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---suppression de toutes les feuilles sauf celle-ci---
For i = Sheets.Count To 1 Step -1
  If i <> Me.Index Then Sheets(i).Delete
Next
'---création des nouvelles feuilles---
For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
  If UCase(Trim(c)) = "DEPART" Then
    Set deb = c
  ElseIf Not deb Is Nothing And UCase(Trim(c)) = "ARRIVEE" Then
    i = c.Row - deb.Row
    nom = deb(1, 2) & IIf(i > 1, " " & deb(2, 2), "") & IIf(i > 2, " " & deb(3, 2), "")
    nom = Left(nom, 31) 'limitation à 31 caractères
    With Sheets.Add(After:=Sheets(Sheets.Count))
      .Name = nom
      Range(deb, c).EntireRow.Copy .[A1]
    End With
    Set deb = Nothing
  End If
Next
Me.Activate
End Sub

A+

 

[job75]

Re,

Si vous tenez vraiment à créer un nouveau fichier :

Private Sub CommandButton1_Click()
Dim fichier$, c As Range, deb As Range, n%, wb As Workbook, i&, nom$
fichier = ThisWorkbook.Path & "\MonBeauFichier" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
  If UCase(Trim(c)) = "DEPART" Then
    Set deb = c
  ElseIf Not deb Is Nothing And UCase(Trim(c)) = "ARRIVEE" Then
    n = n + 1
    If n = 1 Then Set wb = Workbooks.Add 'nouveau document
    i = c.Row - deb.Row
    nom = deb(1, 2) & IIf(i > 1, " " & deb(2, 2), "") & IIf(i > 2, " " & deb(3, 2), "")
    nom = Left(nom, 31) 'limitation à 31 caractères
    With wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
      .Name = nom
      Range(deb, c).EntireRow.Copy .[A1]
    End With
    Set deb = Nothing
  End If
Next
wb.Sheets(1).Delete
wb.Sheets(1).Activate
wb.SaveAs fichier, ThisWorkbook.FileFormat 'enregistrement
wb.Close 'fermeture
End Sub

Fichier (2).

A+

 

[tallia64]

Bonsoir VGENDRON, BELKACEM_64, JOB75,

Je vous remercie beaucoup pour vos macros qui fonctionnent parfaitement
C'est exactement ce que je cherchais et je vais pouvoir les adapter selon mes fichiers.

Bonne soirée

Tallia

 

[job75]

Bonjour Tallia, le forum,

Une solution si l'on veut un bouton dans chaque feuille créée :

Private Sub CommandButton1_Click()
Dim ext$, fichier$, cowc As Boolean, c As Range, deb As Range, n%, wb As Workbook, i&, nom$
ext = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".")) 'extension
fichier = ThisWorkbook.Path & "\MonBeauFichier" & ext 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
cowc = Application.CopyObjectsWithCells 'mémorisation
Application.CopyObjectsWithCells = True 'pour copier les objets copiables
On Error Resume Next
For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
  If LCase(Trim(c)) Like "d?part" Then 'Départ ou DEPART
    Set deb = c
  ElseIf Not deb Is Nothing And LCase(Trim(c)) Like "arriv?e" Then
    n = n + 1
    '---création du fichier et suppression des feuilles---
    If n = 1 Then
      ThisWorkbook.SaveCopyAs fichier 'sauvegarde
      Set wb = Workbooks.Open(fichier) 'ouverture de la sauvegarde
      For i = Sheets.Count To 1 Step -1
        If i <> Me.Index Then wb.Sheets(i).Delete
      Next
    End If
    '---création des feuilles---
    i = c.Row - deb.Row
    nom = deb(1, 2) & IIf(i > 1, " " & deb(2, 2), "") & IIf(i > 2, " " & deb(3, 2), "")
    nom = Left(Application.Trim(nom), 31) 'SUPPRESPACE et limitation à 31 caractères
    With wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
      .Name = nom
      wb.Sheets(1).Rows(1).Copy .[A1]
      Range(deb, c).EntireRow.Copy .[A2]
      .Columns.AutoFit 'ajustement largeur
    End With
    Set deb = Nothing
  End If
Next
If wb Is Nothing Then Kill fichier 'amusant
wb.Sheets(1).Delete
wb.Sheets(1).Activate
wb.Close True 'enregistrement et fermeture
Application.CopyObjectsWithCells = cowc
End Sub

Fichier (3).

A+

 

[tallia64]

Bonjour Job65,

Je te remercie beaucoup pour ton aide et cette nouvelle macro. J'ai une petite question concernant les caractères commençant par une majuscule.
Dans le code de la macro les caractères sont en majuscule soit :

UCase(Trim(c)) = "ARRIVEE"

Si je change le UCase par LCase ce n'est que pour les minuscules.

Quel est le code s'il te plait quand on un mot avec la 1ère lette en majuscule ?
Je te remercie d'avance.

Tallia

 

[tallia64]

Bonjour Job75,

Je te remercie beaucoup pour ton aide et cette nouvelle macro. J'ai une petite question concernant les caractères commençant par une majuscule.
Dans le code de la macro les caractères sont en majuscule soit :

UCase(Trim(c)) = "ARRIVEE"

Si je change le UCase par LCase ce n'est que pour les minuscules.

Quel est le code s'il te plait quand on a un mot avec la 1ère lette en majuscule ?
Je te remercie d'avance.

Tallia

 

[job75]

Bonsoir Tallia,

Vous n'avez pas compris, mais il vous suffisait de tester.

Le code avec UCase (post #6) ou LCase (post #8) est fait pour fonctionner quelle que soit la casse.

Bonne fin de soirée.