Copie d'un tableau nommé sur un autre fichier Excel est une autre

Bonjour à tous,

Je compte sur vous,

J'ai exxcel 2010 et je n'ai pas Power Query.

Je dois réaliser un tableau annuel reprenant 4 tableaux trimstrielles.

PlanningCirculations2019(hors TAC)_1erTrimestre.xlsm" est par exemple l'un de ces tableaux.

Dans chacun de ces tableaux, il y a une feuille nommé "BaseHoraires_Tableau_" et dedans cette feuille, un tableau nommé "Tableau_Production".

J'aimerai copier les 4 tableaux production, (afin de ne pas me prendre la tête avec tous les formats de données sur un autre classeur et un autre feuille qui serait ma table principale que je mettrai en jour en cliquant sur un simple bouton...

Le souci, c'est que je bloque, j'ai passé l'après midi à bloquer. mon responsable attend de moi ce tableau et à part moi même faire le copier/coller, je ne vois pas comment faire autrement.

Merci beaucoup à tout ceux qui regarderont.

Dim AW As Workbook
Sheets("Tableau_Production_Avenir").Activate
Set AW = ActiveWorkbook

'Affiche le chemin et le nom du fichier sélectionné.
'MsgBox Fichier
Dim WS As Workbook

MsgBox "L'application va mettre à jour la base de données de la production prévu sur l annee. Assurez-vous que les différents tableaux présents dans ce fichier soient disponibles a la lecture."

Dim sheetExists As Boolean
Dim sheetToFind As String
Dim comparaison As String
Dim WorkBookToOpen As String
Dim ListTableau As ListObject
Dim y As Integer

Dim Tableau(4) As String

Tableau(1) = "PlanningCirculations2019(hors TAC)_1erTrimestre.xlsm"
Tableau(2) = "PlanningCirculations2019(hors TAC)_2emeTrimestre.xlsm"
Tableau(3) = "PlanningCirculations2019(hors TAC)_3emeTrimestre.xlsm"
Tableau(4) = "PlanningCirculations2019(hors TAC)_4emeTrimestre.xlsm"

y = 2 ' je place le curseur au debut du tableau nb ligne

Sheets.Add(Before:=Worksheets("Data")).Name = "Test"

Dim NomDossierGenerique As String
Dim chemin As String

For t = 1 To 4

    chemin = "\\s56cfgse636\Etablissements\DDTER\Pole Production TER\CCL Thermique CF\ASSEMBLAGE PRODUCTION\"

    NomDossierGenerique = chemin & Tableau(t)

    ' jouvre le fichier
    'Workbooks.Open (NomDossierGenerique)

    'Set WS = Workbooks(Tableau(t))
    Set WS = Workbooks.Open(Filename:=NomDossierGenerique)

    'je mets sheetexiste a faux pour commencer mon iteration
    sheetToFind = "BaseHoraires_Tableau_"
    sheetExists = False

    For Each Sheet In Worksheets

        For i = 1 To 4

            comparaison = sheetToFind & i

                If comparaison = Sheet.Name Then

                    Set ListObj = Worksheets(comparaison).ListObjects("Tableau_Production")

                    MsgBox "pause1"

                    If Worksheets(comparaison).ListObjects("Tableau_Production") <> "" Then
                        MsgBox "coucou"
                    End If

                    AW.Activate

                     If AW.Sheets("Test").Name <> "" Then
                        MsgBox "coucou2"
                    End If

                    Worksheets(comparaison).ListObjects("Tableau_Production").Range.Copy _
                        Destination:=Worksheets(4).Range(Cells(y, 1))
                    '("Test").Range(Cells(y, 1))

                    MsgBox "pause2"

                    Do While Cells(y, 1).Value <> ""

                        y = y + 1

                    Loop

                    MsgBox "pause3"

                End If

        Next

    Next Sheet

Next

Bonjour,

je ne suis pas certaine d'avoir bien compris,

il y a 4 fichiers dans le répertoire (chemin)

chacun de ces fichier ont 4 feuilles

sur chaque feuille il y a 1 tableau nommé "Tableau_Production" (4 tableau dans le même fichier portant le même nom) ?

Sub transfert()
Dim wk1 As Workbook
Dim wk2 As Workbook
Dim NomDossierGenerique As String
Dim chemin As String
Dim T As Integer, i As Long, rw As Long

Dim Tableau(4) As String
Tableau(1) = "PlanningCirculations2019(hors TAC)_1erTrimestre.xlsm"
Tableau(2) = "PlanningCirculations2019(hors TAC)_2emeTrimestre.xlsm"
Tableau(3) = "PlanningCirculations2019(hors TAC)_3emeTrimestre.xlsm"
Tableau(4) = "PlanningCirculations2019(hors TAC)_4emeTrimestre.xlsm"

chemin = "\\s56cfgse636\Etablissements\DDTER\Pole Production TER\CCL Thermique CF\ASSEMBLAGE PRODUCTION\"

Set wk1 = ThisWorkbook
Sheets.Add Before:=Worksheets("Data")
ActiveSheet.Name = "Test"

For T = 1 To 4
    NomDossierGenerique = chemin & Tableau(T)
    Set wk2 = Workbooks.Open(Filename:=NomDossierGenerique)
    wk1.Activate

    For i = 1 To 4
     If Not IsError(Sheets("BaseHoraires_Tableau_" & i)) Then
        With Sheets("BaseHoraires_Tableau_" & i).ListObjects("Tableau_Production")
            Set objListTitle = .HeaderRowRange
            Set objListRows = .DataBodyRange.SpecialCells(xlCellTypeConstants)
            If i = 1 Then objListTitle.Copy ActiveSheet.Range("A1")
            rw = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
            objListRows.Copy ActiveSheet.Range("A" & rw)
        End With

     End If
    Next i
    wk2.Close False
Next T
End Sub

Bonjour

Oui c'est cela. Tu as bien compris

Pour l'instant, je suis perdu.

Je vais essayé de faire sur un seul tableau / onglet et sur le 5eme onglet essayer de tout rassembler, en essayant d'éviter de perdre des informations. C'est ma plus grosse crainte.

Merci d'avance pour vos retours.

Je suis content que vous vous intéressiez à mon problème.

re,

est-ce que la macro transfert fonctionne ?

Bonjour,

Bonjour i20100,

Une autre proposition à étudier.

Un nom de tableau (structuré) est unique dans un classeur.

Pour ta crainte de perte de données, j'ai ajouté une vérification : nombre de lignes consolidée = somme des nombres de lignes de chaque tableau copié.

A te relire.

Cdlt.

4gulkcherche16.xlsm (21.51 Ko)
Public Sub Consolidation()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim lo As ListObject
Dim rng As Range, rng2 As Range
Const strFOLDER As String = "\\s56cfgse636\Etablissements\DDTER\Pole Production TER\CCL Thermique CF\ASSEMBLAGE PRODUCTION\"
Dim tbl(1 To 4) As String
Dim i As Long, lRow As Long, ModeCalc As Long, n As Long, n2 As Long

    With Application
        ModeCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    tbl(1) = "PlanningCirculations2019(hors TAC)_1erTrimestre.xlsm"
    tbl(2) = "PlanningCirculations2019(hors TAC)_2emeTrimestre.xlsm"
    tbl(3) = "PlanningCirculations2019(hors TAC)_3emeTrimestre.xlsm"
    tbl(4) = "PlanningCirculations2019(hors TAC)_4emeTrimestre.xlsm"

    Set wb2 = ThisWorkbook
    On Error Resume Next
    wb2.Worksheets("Test").Delete
    On Error GoTo 0
    Set ws = wb2.Worksheets.Add(before:=Worksheets("Data"))
    ws.Name = "Test"

    Application.DisplayAlerts = True

    For i = 1 To 4
        Set wb = Workbooks.Open(strFOLDER & tbl(i))
        On Error Resume Next
        'Le nom d'un tableau est unique dans un classeur
        Set rng = Range("Tableau_Production")
        On Error GoTo 0
        If Not rng Is Nothing Then
            Set lo = rng.ListObject
            If lo.InsertRowRange Is Nothing Then
                n = n + lo.ListRows.Count
                Set rng2 = IIf(i = 1, lo.Range, lo.DataBodyRange)
                lRow = IIf(i = 1, 1, ws.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                rng2.Copy
                ws.Cells(lRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False
            End If
        End If
        wb.Close False
    Next i

    With ws
        Set lo = .ListObjects.Add(xlSrcRange, .Cells(1).CurrentRegion, , xlYes)
        With lo
            .Name = "Tableau_Production"
            .TableStyle = "TableStyleLight11"
            n2 = .ListRows.Count
        End With
    End With

    If n = n2 Then
        MsgBox "La consolidation s'est bien déroulée.", vbInformation, "Consolidation"
    Else
        MsgBox "Il y a eu un problème lors de la consolidation", vbCritical, "Consolidation"
    End If

    Application.Calculation = xlCalculationAutomatic

End Sub

Bonjour,

Jean-Eric,

Je te remercie beaucoup pour ce travail.

Je suis fan de ton code, qui fonctionne bien et qui est super propre.

Pourrais-tu me le commenter ? à partir du For.

J'ai pas l'habitude d'utiliser les On Error, et les With qui reprennent plusieurs commandes,

Merci d'avance, je suis vraiment très content.

Re,

Merci pour ce retour.

Je te renvoie le classeur avec des commentaires dans la procédure VBA.

A te relire.

Cdlt.

3gulkcherche16.xlsm (22.58 Ko)

Nota : N'oublie de remercier I20100 pour son intervention et sa procédure qui doit elle aussi répondre à ta demende.

Merci une nouvelle fois, pou les commentaires,

je vais essayer dans mes productions de m'inspirer de ton code,

j'ai vu quelque chose d'intéressant, IIF( , , )

C'est vachement bien cela, si c'est j'ai bien compris, cela fonction comme =SI(condiion,si vrai,si faux).

Bonjour,

Dois-je le considérer comme résolu pour l'intérêt du forum ? si ou je ne vois quelle procédure faire ?

Merci d'avance pour réponse.

Re,

Quelle est la question ?

Cdlt.

Vu que tu as répondu à ma question dois je cloturer ce post ?

Re,

Si tu considères que les réponses sont satisfaisantes, oui !...

Cdlt.

comment fais-je ? je ne vois rien pour le déclarer "Cloturé"

re,

pour clôturer le fil, clic sur le bouton

resolu

merci

Rechercher des sujets similaires à "copie tableau nomme fichier"