Copie d'un tableau nommé sur un autre fichier excel est une autre Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
G
GulkCherche16
Jeune membre
Jeune membre
Messages : 11
Inscrit le : 22 février 2019
Version d'Excel : 2010

Message par GulkCherche16 » 22 février 2019, 16:09

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
Avatar du membre
i20100
Passionné d'Excel
Passionné d'Excel
Messages : 5'014
Appréciations reçues : 258
Inscrit le : 16 mars 2017
Version d'Excel : 2010 sur PC

Message par i20100 » 23 février 2019, 15:46

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
Merci! de faire un clic sur le bouton résolu pour nous aider à t'aider.
Si vous avez un doute :
annonces/explications-et-regles-a-respecter-t13.html

isabelle
G
GulkCherche16
Jeune membre
Jeune membre
Messages : 11
Inscrit le : 22 février 2019
Version d'Excel : 2010

Message par GulkCherche16 » 26 février 2019, 10:00

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.
Avatar du membre
i20100
Passionné d'Excel
Passionné d'Excel
Messages : 5'014
Appréciations reçues : 258
Inscrit le : 16 mars 2017
Version d'Excel : 2010 sur PC

Message par i20100 » 1 mars 2019, 00:51

re,

est-ce que la macro transfert fonctionne ?
Merci! de faire un clic sur le bouton résolu pour nous aider à t'aider.
Si vous avez un doute :
annonces/explications-et-regles-a-respecter-t13.html

isabelle
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'439
Appréciations reçues : 545
Inscrit le : 27 août 2012
Version d'Excel : 365 Insider

Message par Jean-Eric » 1 mars 2019, 07:47

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.
GulkCherche16.xlsm
(21.51 Kio) Téléchargé 2 fois
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
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
G
GulkCherche16
Jeune membre
Jeune membre
Messages : 11
Inscrit le : 22 février 2019
Version d'Excel : 2010

Message par GulkCherche16 » 1 mars 2019, 10:31

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.

:mrgreen:
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'439
Appréciations reçues : 545
Inscrit le : 27 août 2012
Version d'Excel : 365 Insider

Message par Jean-Eric » 1 mars 2019, 10:57

Re,
Merci pour ce retour.
Je te renvoie le classeur avec des commentaires dans la procédure VBA.
A te relire.
Cdlt.
GulkCherche16.xlsm
(22.58 Kio) Téléchargé 3 fois
Nota : N'oublie de remercier I20100 pour son intervention et sa procédure qui doit elle aussi répondre à ta demende. :wink:
1 membre du forum aime ce message.
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
G
GulkCherche16
Jeune membre
Jeune membre
Messages : 11
Inscrit le : 22 février 2019
Version d'Excel : 2010

Message par GulkCherche16 » 1 mars 2019, 13:16

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).
G
GulkCherche16
Jeune membre
Jeune membre
Messages : 11
Inscrit le : 22 février 2019
Version d'Excel : 2010

Message par GulkCherche16 » 4 mars 2019, 13:39

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.
Avatar du membre
Jean-Eric
Fanatique d'Excel
Fanatique d'Excel
Messages : 15'439
Appréciations reçues : 545
Inscrit le : 27 août 2012
Version d'Excel : 365 Insider

Message par Jean-Eric » 4 mars 2019, 13:42

Re,
Quelle est la question ?
Cdlt.
Jean-Eric

Je ne réponds pas aux M.P. non sollicités.
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message