VBA: consolidation des diverrs données dans une meme feuille

Le 05/03/2014 à 14:05

Bonjour,

J'ai une macro qui fonctionne parfaitement avec mes conditions actuelles!( un non unique de feuilles a chercher qui est "Actual GB AAA")

Maintenant, j'ai trois noms de feuille differents a aller chercher( "Actual GB AAA","Actual GB BBB","Actual GB CCC")

A partir de ma macro, pourriez vous svp me donner une ecriture qui puisse prendre en compte les trois noms de feuilles.

Merci d'avance cella me sera d'une grande utilité.

Ci-dessous mon code de base.

Sub HC_Global()

'Variables Declaration
Dim Path As String, File As String
Dim Worksheet As Worksheet
Dim Target_Worksheet As String
Dim OK_Worksheet As Boolean, Start As Boolean
Dim Name As Name
Dim FirstLine As Long, LastLine As Long, LastLineTarget As Long
Dim FirstColumn As Long, LastColumn As Long

    Target_Worksheet = "Actual GB AAA"
        ThisWorkbook.Sheets(Target_Worksheet).Cells.Clear
        Path = ThisWorkbook.Path
    Start = True

    'If unsaved file, then no path => always save the file before executing the macro
    If Path <> "" Then
        'Filters only on Excel files
        File = Dir(Path & "\*.*xls*")
        'Only "esthetic" : improves speed and processing appearance (deactivating sreen update)
        Application.ScreenUpdating = False

        Do While File <> ""
            If File <> ThisWorkbook.Name Then
                Workbooks.Open Filename:=Path & "\" & File, ReadOnly:=True, UpdateLinks:=False

                Application.DisplayAlerts = False

                'Test if worksheet exists
                OK_Worksheet = False
                For Each Worksheet In Workbooks(File).Sheets
                    If Worksheet.Name = Target_Worksheet Then OK_Worksheet = True: Exit For
                Next

                'If worksheet OK => copies worksheet content to "Global" file
                If OK_Worksheet Then

                Worksheet.Unprotect Password:="FCII"
                Worksheet.Columns.Ungroup
                Worksheet.AutoFilterMode = False

                    'Sets the range to copy in "Global"
                    FirstLine = Lookforfirstline(Workbooks(File), Target_Worksheet) + 1
                        If Not Start Then FirstLine = FirstLine + 1
                        Start = False
                            LastLine = LookforLastline(Workbooks(File), Target_Worksheet)
                            FirstColumn = LookforFirstColumn(Workbooks(File), Target_Worksheet)
                            LastColumn = LookforLastColumn(Workbooks(File), Target_Worksheet)
                            LastLineTarget = LookforLastline(ThisWorkbook, "Actual GB AAA") + 1

                            'No copy of the header if not the first file copied
                        With Workbooks(File).Sheets(Target_Worksheet)
                            .Range(.Cells(FirstLine, FirstColumn).Address & ":" & .Cells(LastLine, LastColumn).Address).Copy Destination:=ThisWorkbook.Sheets("Actual GB AAA").Range("A" & LastLineTarget)
                        End With

                       'Deletes named cells
                        For Each Name In ThisWorkbook.Names
                            Name.Delete
                        Next

                    Start = False
                    End If
            Worksheet.Protect Password:="FCII"
            Workbooks(File).Close False
            End If
        File = Dir
        Loop

    'Breaks Links
    Dim Link As Variant
    For Each Link In ActiveWorkbook.LinkSources
        ActiveWorkbook.BreakLink Name:=Link, Type:=1
    Next

    'Deletes Data/Validation
    Sheets("Actual GB AAA").Select
    Cells.Validation.Delete

    'Deletes Conditional Formatting
    Sheets("Actual GB AAA").Select
    Cells.FormatConditions.Delete

    'Sorts data by Name & First Name
    Cells.Select
    ActiveWorkbook.Worksheets("Actual GB AAA").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Actual GB AAA").Sort.SortFields.Add Key:=Range( _
        "l2:l1048576"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Actual GB AAA").Sort.SortFields.Add Key:=Range( _
        "m2:m1048576"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Actual GB AAA").Sort
        .SetRange Rows("1:01048576")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' Filters
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter

    Sheets("Updates").Select

   ' Re-activates Display Alerts
    Application.DisplayAlerts = True

   ' Re-activates screen update
    Application.ScreenUpdating = True
    End If
Le 05/03/2014 à 14:31
Sub HC_Global()

'Variables Declaration
Dim Path As String, File As String
Dim Worksheet As Worksheet
Dim Target_Worksheet As String
Dim OK_Worksheet As Boolean, Start As Boolean
Dim Name As Name
Dim FirstLine As Long, LastLine As Long, LastLineTarget As Long
Dim FirstColumn As Long, LastColumn As Long

tab(1)="Actual GB AAA"
tab(2)="Actual GB BBB"
tab(2)="Actual GB CCC"
For i = 1 to 3

    Target_Worksheet = tab(i)
        ThisWorkbook.Sheets(Target_Worksheet).Cells.Clear
        Path = ThisWorkbook.Path
    Start = True

    'If unsaved file, then no path => always save the file before executing the macro
   If Path <> "" Then
        'Filters only on Excel files
       File = Dir(Path & "\*.*xls*")
        'Only "esthetic" : improves speed and processing appearance (deactivating sreen update)
       Application.ScreenUpdating = False

        Do While File <> ""
            If File <> ThisWorkbook.Name Then
                Workbooks.Open Filename:=Path & "\" & File, ReadOnly:=True, UpdateLinks:=False

                Application.DisplayAlerts = False

                'Test if worksheet exists
               OK_Worksheet = False
                For Each Worksheet In Workbooks(File).Sheets
                    If Worksheet.Name = Target_Worksheet Then OK_Worksheet = True: Exit For
                Next

                'If worksheet OK => copies worksheet content to "Global" file
               If OK_Worksheet Then

                Worksheet.Unprotect Password:="FCII"
                Worksheet.Columns.Ungroup
                Worksheet.AutoFilterMode = False

                    'Sets the range to copy in "Global"
                   FirstLine = Lookforfirstline(Workbooks(File), Target_Worksheet) + 1
                        If Not Start Then FirstLine = FirstLine + 1
                        Start = False
                            LastLine = LookforLastline(Workbooks(File), Target_Worksheet)
                            FirstColumn = LookforFirstColumn(Workbooks(File), Target_Worksheet)
                            LastColumn = LookforLastColumn(Workbooks(File), Target_Worksheet)
                            LastLineTarget = LookforLastline(ThisWorkbook, "Actual GB AAA") + 1

                            'No copy of the header if not the first file copied
                       With Workbooks(File).Sheets(Target_Worksheet)
                            .Range(.Cells(FirstLine, FirstColumn).Address & ":" & .Cells(LastLine, LastColumn).Address).Copy Destination:=ThisWorkbook.Sheets("Actual GB AAA").Range("A" & LastLineTarget)
                        End With

                       'Deletes named cells
                       For Each Name In ThisWorkbook.Names
                            Name.Delete
                        Next

                    Start = False
                    End If
            Worksheet.Protect Password:="FCII"
            Workbooks(File).Close False
            End If
        File = Dir
        Loop

    'Breaks Links
   Dim Link As Variant
    For Each Link In ActiveWorkbook.LinkSources
        ActiveWorkbook.BreakLink Name:=Link, Type:=1
    Next

    'Deletes Data/Validation
   Sheets("Actual GB AAA").Select
    Cells.Validation.Delete

    'Deletes Conditional Formatting
   Sheets("Actual GB AAA").Select
    Cells.FormatConditions.Delete

    'Sorts data by Name & First Name
   Cells.Select
    ActiveWorkbook.Worksheets("Actual GB AAA").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Actual GB AAA").Sort.SortFields.Add Key:=Range( _
        "l2:l1048576"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Actual GB AAA").Sort.SortFields.Add Key:=Range( _
        "m2:m1048576"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Actual GB AAA").Sort
        .SetRange Rows("1:01048576")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' Filters
   Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter

    Sheets("Updates").Select

   ' Re-activates Display Alerts
   Application.DisplayAlerts = True

   ' Re-activates screen update
   Application.ScreenUpdating = True
    End If
next i
Le 05/03/2014 à 14:44

Merci pour cette reponse

mais j'ai le message suivant quand je lance ma macro "compile error syntax error"

alors je me demandais s'il faut que je change quelque chose si oui quoi ?

car j'ai fait un copier coller de votre macro

Merci

Le 05/03/2014 à 15:23

en gros quand je rajoute ceci a ma macro

tab(1)="Actual GB AAA"

tab(2)="Actual GB BBB"

tab(2)="Actual GB CCC"

cette partie là reste en rouge. et c'est que vient le probleme je pense.

d'ailleurs pour "tab(2)="Actual GB CCC" ce serait pas par hasard "ta(3)=..." ?

merci d'avance!

Le 05/03/2014 à 15:26

En effet définit ton tableau alors

Dim tab

Le 05/03/2014 à 15:30

juste a la suite de "Dim FirstColumn As Long, LastColumn As Long" je met quoi "Dim tab As Worksheet" c'est bien ça?

Le 05/03/2014 à 15:39

Dim tab

tout court ou alors

dim tab(1 to 3) as string

Le 05/03/2014 à 16:09

bonjour,

selon moi tab est un mot réservé et ne peut pas être utilisé comme nom de variable.

Le 05/03/2014 à 16:25

Merci encore mais une fois de plus ces lignes se mettent toujours en rouge et j'ai toujours le meme message d'erreur

Dim tab

tab(1)="Actual GB AAA"

tab(2)="Actual GB BBB"

tab(3)="Actual GB CCC"

c'est quoi la difference entre Dim tag et Dim tab?

car quand je remplace tab par tag les lignes deviennent normales mais la variable i reste un probleme

Le 05/03/2014 à 16:55
Dim tabl

tabl(1)="Actual GB AAA"
tabl(2)="Actual GB BBB"
tabl(3)="Actual GB CCC"
For i = 1 to 3

    Target_Worksheet = tabl(i)
Le 05/03/2014 à 17:09

merci ça suppose donc que partout ou j'ai "Actual GB AAA" je remplace par tabl(i) ou je met tous les noms separé de ";"?

Le 05/03/2014 à 17:14

remplace par

Target_Worksheet

Le 06/03/2014 à 10:34

bonjour,

voila au juste ce que j'ai au final mais helas ça ne marche toujours pas

voila le message d'erreur que j'ai "subscript out of range"

ci dessous ma macro

quelqu'un decele t-il un probleme?

merci d'avance pour votre aide

Sub HC_Global()

'Variables Declaration
Dim Path As String, File As String
Dim Worksheet As Worksheet
Dim Target_Worksheet As String
Dim OK_Worksheet As Boolean, Start As Boolean
Dim Name As Name
Dim FirstLine As Long, LastLine As Long, LastLineTarget As Long
Dim FirstColumn As Long, LastColumn As Long
Dim tabl(1 To 3) As String
Dim i

tabl(1) = "Actual GB AAA"
tabl(2) = "Actual GB BBB"
tabl(3) = "Actual GB CCC"
For i = 1 To 3

    Target_Worksheet = tabl(i)
        ThisWorkbook.Sheets(Target_Worksheet).Cells.Clear
        Path = ThisWorkbook.Path
    Start = True

    'If unsaved file, then no path => always save the file before executing the macro
    If Path <> "" Then
        'Filters only on Excel files
        File = Dir(Path & "\*.*xls*")
        'Only "esthetic" : improves speed and processing appearance (deactivating sreen update)
        Application.ScreenUpdating = False

        Do While File <> ""
            If File <> ThisWorkbook.Name Then
                Workbooks.Open Filename:=Path & "\" & File, ReadOnly:=True, UpdateLinks:=False

                Application.DisplayAlerts = False

                'Test if worksheet exists
                OK_Worksheet = False
                For Each Worksheet In Workbooks(File).Sheets
                    If Worksheet.Name = Target_Worksheet Then OK_Worksheet = True: Exit For
                Next

                'If worksheet OK => copies worksheet content to "Global" file
                If OK_Worksheet Then

                Worksheet.Unprotect Password:="FCII"
                Worksheet.Columns.Ungroup
                Worksheet.AutoFilterMode = False

                    'Sets the range to copy in "Global"
                    FirstLine = Lookforfirstline(Workbooks(File), Target_Worksheet) + 1
                        If Not Start Then FirstLine = FirstLine + 1
                        Start = False
                            LastLine = LookforLastline(Workbooks(File), Target_Worksheet)
                            FirstColumn = LookforFirstColumn(Workbooks(File), Target_Worksheet)
                            LastColumn = LookforLastColumn(Workbooks(File), Target_Worksheet)
                            LastLineTarget = LookforLastline(ThisWorkbook, Target_Worksheet) + 1

                            'No copy of the header if not the first file copied
                        With Workbooks(File).Sheets(Target_Worksheet)
                            .Range(.Cells(FirstLine, FirstColumn).Address & ":" & .Cells(LastLine, LastColumn).Address).Copy Destination:=ThisWorkbook.Sheets(Target_Worksheet).Range("A" & LastLineTarget)
                        End With

                       'Deletes named cells
                        For Each Name In ThisWorkbook.Names
                            Name.Delete
                        Next

                    Start = False
                    End If
            Worksheet.Protect Password:="FCII"
            Workbooks(File).Close False
            End If
        File = Dir
        Loop

    'Breaks Links
    Dim Link As Variant
    For Each Link In ActiveWorkbook.LinkSources
        ActiveWorkbook.BreakLink Name:=Link, Type:=1
    Next

    'Deletes Data/Validation
    Sheets(Target_Worksheet).Select
    Cells.Validation.Delete

    'Deletes Conditional Formatting
    Sheets(Target_Worksheet).Select
    Cells.FormatConditions.Delete

    'Sorts data by Name & First Name
    Cells.Select
    ActiveWorkbook.Worksheets(Target_Worksheet).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(Target_Worksheet).Sort.SortFields.Add Key:=Range( _
        "l2:l1048576"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets(Target_Worksheet).Sort.SortFields.Add Key:=Range( _
        "m2:m1048576"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets(Target_Worksheet).Sort
        .SetRange Rows("1:01048576")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' Filters
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter

    Sheets("Updates").Select

   ' Re-activates Display Alerts
    Application.DisplayAlerts = True

   ' Re-activates screen update
    Application.ScreenUpdating = True
    End If

Next i

End Sub
Le 06/03/2014 à 10:52

.SetRange Rows("1:01048576")

Ici problème

Le 06/03/2014 à 15:55

et que dois je faire precisement de ce .SetRange Rows("1:01048576")

merci d'avance

Le 06/03/2014 à 16:07

enlever ce zéro avant ton 1

Le 06/03/2014 à 16:31

j'avais deja essayé sans ce zero devant le 1 mais ca ne fonctionne pas alors je me dis que le probleme est ailleurs.

et sincerement je ne vois pas

Le 07/03/2014 à 14:22

salut tout le monde!

je n'est toujours pas de solution a mon probleme

quelqu'un pour m'aider please?

Le 07/03/2014 à 14:54

Bonjour,

sur quelle instruction reçois-tu ce message d'erreur ?

Le 07/03/2014 à 16:07

alors juste quand je lance ma macro j'ai ce message " Subscript out of range" rien d'autre

Rechercher des sujets similaires à "vba consolidation diverrs donnees meme feuille"