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.
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.
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é"