Correction de Macro

Bonjour, aprés avoir crée une macro, ca finis par ne pas marché. Est il possible de m'aider à corriger cette macro svp:

Sub copy()
Dim sh As Worksheet
Dim i As Long
Dim j As Long
Dim A As Integer
Dim k As Integer
Dim H As Integer

For Each sh In ThisWorkbook.Sheets
With sh
For i = 1 To .Range("A" & Rows.Count).Row
For j = 1 To .Cells(Columns.Count, 1).Column
If .Cells(i, j).Interior.ColorIndex = 3 Then
.Cells(i, j).Interior.ColorIndex = 3 = H
H.EntireRow.copy Destination:=Sheets("Idées à suivre")
k = k + 1
End If
Next j
Next i
End With
Next
End Sub

Bonjour,

Sub copier()
Dim sh As Worksheet
Dim i As Long, j As Long
Dim A As Integer, k As Integer, H As Integer
    k = 1
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "Idées à suivre" Then
        With sh
            For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row
                For j = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
                    If .Cells(i, j).Interior.ColorIndex = 3 Then
                        .Cells(i, j).EntireRow.copy Destination:=Sheets("Idées à suivre").Rows(k)
                        k = k + 1
                    End If
                Next j
            Next i
        End With
        End If
    Next
End Sub

A+

Bonjour,

A tester et adapter suivant tes besoins.

Option Explicit
Public Sub copier()
Dim Ws As Worksheet, Sh As Worksheet
Dim i As Long, j As Long
Dim Derligne As Long

    Application.ScreenUpdating = False
    Set Ws = Worksheets("Idées à suivre")
    Ws.Cells.Clear
    Derligne = Ws.Range("A" & Rows.Count).End(xlUp).Row
    For Each Sh In ActiveWorkbook.Worksheets
        If Sh.Name <> Ws.Name Then
            With Sh
                For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
                    For j = 1 To .Cells(1, Cells.Columns.Count).End(xlToLeft).Column
                        If .Cells(i, j).Interior.ColorIndex = 3 Then
                            Rows(i).EntireRow.copy Destination:=Ws.Cells(Derligne, 1)
                            Derligne = Ws.Range("A" & Rows.Count).End(xlUp).Row + 1
                        End If
                    Next j
                Next i
            End With
        End If
    Next Sh

    With Ws
        .Columns(1).Interior.ColorIndex = xlNone
    End With

    Set Ws = Nothing
End Sub

Merci bien! c'est bien corrigé

Sinn! j'éssaye de sélectionner quelque feuilles et non pas comme écrit For Each sh In ThisWorkbook.Sheets

Comment faire?

Re,

Peux-tu envoyer un fichier exemple de ce que tu souhaites?

Un fichier avec des données significatives, évidemment

Le voila =)

Re,

Voir fichier

Bonne journée à toi

Merci pour ta réponse Jean-Eric. Ca c'est du code! Ca prend par contre du temps pour chargé, y'a t il une solution pour ca?!

Bonjour,

Dans le fichier joint, c'est instantané. Tout dépend du nombre de feuilles et du nombre de lignes à traiter.

Bonjour,

Le fichier joint c'était juste un petit exemple pour simplifier, mais au niveau du document officiel il y'a 7 collones de 13 rang a insérer après la cellule rouge, avec une importante quantité de texte. Et pour l'instant ca bloque carrément le document =S j'ai rien pu améliorer au programme:

Public Sub idéesorange()
Dim Ws As Worksheet, Sh As Worksheet
Dim i As Long, j As Long
Dim Derligne As Long
Dim DerLig As Long, DerCol As Long

    Application.ScreenUpdating = False
    Set Ws = Worksheets("Idées à présenter")
    Ws.Cells.Clear
    Derligne = Ws.Range("A" & Rows.Count).End(xlUp).Row

    For Each Sh In ActiveWorkbook.Worksheets

        DerLig = Sh.Range("A" & Rows.Count).End(xlDown).Row
        DerCol = Sh.Cells(1, Cells.Columns.Count).End(xlToLeft).Column

        If Sh.Name <> Ws.Name And DerLig > 1 Then

            With Sh
                For i = 1 To DerLig
                    If .Cells(i, 1).Interior.ColorIndex = 40 Then
                        .Rows(i).Range("A1:L1").copy Destination:=Ws.Cells(Derligne, 1)
                        Ws.Cells(Derligne, DerCol + 0) = Sh.Name
                        Derligne = Ws.Range("A" & Rows.Count).End(xlUp).Row + 1
                    End If
                Next i
            End With

        End If

    Next Sh

    With Ws
        .Columns(2).Interior.ColorIndex = xlNone
    End With

    Set Ws = Nothing
    Sheets("Idées à présenter").Select
End Sub

Bonsoir,

Je ne sais pas ce que tu veux faire, mais tu modifier:

.Rows(i).Range("A1:L1").copy Destination:=Ws.Cells(Derligne, 1)
Ws.Cells(Derligne, DerCol + 0) = Sh.Name

par

.Cells(i, 1).Resize(1, 12).Copy Destination:=Ws.Cells(Derligne, 1)
Ws.Cells(Derligne, DerCol + 1) = Sh.Name

Cdlt