VBA= Si pas de données, ne pas créer de fichier d'export
Bonsoir à tous,
Mon projet arrive sur la fin grâce a vous et quelques nuits blanches...
J'aurais besoin de vos lumières concernant la modification d'une macro.
En effet celle ci récupère des données d'un tableau sur la feuille "Indem horaire travail DJF" et les importe dans une feuille "Saisie_masse_1453_SIRH" pour enfin créer un fichier Saisie_masse_1453_SIRH.xlsx avec les données du tableau. Petite précision, si déclenche la macro d'import plusieurs fois, les lignes se rajoutent les unes en dessous des autres, c'est voulu)
Ma demande réside sur le fait que je voudrais ne pas créer de fichier Saisie_masse_1453_SIRH.xlsx si le tableau sans l'onglet Saisie_masse_1453_SIRH est vide à partir de la seconde ligne.
Je ne peux pas mettre de fichier car mon projet est pratiquement finalisé et il contient notamment des données.
Néanmoins voici le code ainsi que le tableau récupéré par la macro synthèse en espérant que cela suffise a vous aider à la compréhension, sinon je suis assez réactif pour répondre aux questions.
Merci par avance.
Christophe.
'Private Sub Worksheet_Activate()
'Sheets("Injection").Visible = Not Sheets("Injection").Visible
'End Sub
Option Explicit
Sub Synthese_1453()
Dim NbLg As Long, Ligne As Long
Dim WsL As Worksheet, Ws As Worksheet
Dim Cel As Range, Kase As Range
Dim LesFeuilles
Dim i As Integer, Colonne As Integer
ActiveWorkbook.Unprotect Password:="200997"
Application.ScreenUpdating = False
Set Ws = Sheets("Saisie_masse_1453_SIRH")
Ws.Unprotect Password:="200997"
Ws.Range("A2:L" & Rows.Count).ClearContents
Ligne = 1
Set WsL = Sheets("Liste complète des PERS DIR")
LesFeuilles = Array("Indem horaire travail DJF")
For i = 0 To UBound(LesFeuilles)
With Sheets(LesFeuilles(i))
.Unprotect Password:="200997"
NbLg = .Range("B" & Rows.Count).End(xlUp).Row + 1
If i = 2 Then Colonne = 8 Else Colonne = 8
.Range(.Cells(17, Colonne), .Cells(NbLg, Colonne)).AutoFilter field:=1, Criteria1:=">0"
'.Range("L17:L" & NbLg).AutoFilter field:=1, Criteria1:=">0"
If Application.Subtotal(103, .Range("B18:B" & NbLg)) > 0 Then
For Each Cel In .Range("B18:B" & NbLg).SpecialCells(xlCellTypeVisible)
If Cel <> "" Then
Set Kase = WsL.Columns("A").Find(what:=Replace(Replace(Cel, " ", ""), "|", ""), LookIn:=xlValues, lookat:=xlPart)
If Not Kase Is Nothing Then
Ligne = Ligne + 1
'Récupération des données
Ws.Range("A" & Ligne) = Cel.Offset(0, 7)
Ws.Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
Ws.Range("C" & Ligne) = Cel.Offset(0, 8)
Ws.Range("D" & Ligne) = Cel.Offset(0, 9)
'Ws.Range("E" & Ligne) = Cel.Offset(0, 14)
'Ws.Range("F" & Ligne) = Cel.Offset(0, 15)
' Ws.Range("G" & Ligne) = Cel.Offset(0, 16)
' Ws.Range("H" & Ligne) = Cel.Offset(0, 17)
' Ws.Range("I" & Ligne) = Cel.Offset(0, 18)
' Ws.Range("J" & Ligne) = Cel.Offset(0, 19)
'Ws.Range("K" & Ligne) = Cel.Offset(0, 20)
'Ws.Range("L" & Ligne) = .Range("A1")
'Mise en forme des données
' Range("C2:C" & NbLg).NumberFormat = "# #0,0"
' Range("D2:D" & NbLg).NumberFormat = "0.00"
'Range("E2:E" & NbLg).NumberFormat = "0.00"
'Range("F2:F" & NbLg).NumberFormat = "# #0,0"
' Range("G2:G" & NbLg).NumberFormat = "# ##0,00"
' Range("H2:H" & NbLg).NumberFormat = "0.00"
' Range("I2:I" & NbLg).NumberFormat = "# #0,0"
' Range("J2:J" & NbLg).NumberFormat = "# ##0,00"
' Range("K2:K" & NbLg).NumberFormat = "0.00"
' Range("A2:L" & NbLg).HorizontalAlignment = xlCenter
' Range("A2:L" & NbLg).VerticalAlignment = xlCenter
'Ws.Range("A" & Ligne) = Kase
'Ws.Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
'Ws.Range("C" & Ligne) = .Range("M2")
'Ws.Range("D" & Ligne) = .Range("N3")
'Ws.Range("E" & Ligne) = CDate(.Range("E12"))
'Ws.Range("F" & Ligne) = .Cells(Cel.Row, Colonne) * 100 'Cel.Offset(0, 10)
Else
MsgBox "Code " & Cel & " introuvable"
End If
End If
Next Cel
End If
.AutoFilterMode = False
.Protect Password:="200997"
ActiveWorkbook.Protect Password:="200997"
End With
Next i
InjectionGlobal_1453
MsgBox "Export pour SIRH HARMONIE effectué"
End Sub
Sub InjectionGlobal_1453()
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim NbLg As Long
ActiveWorkbook.Unprotect Password:="200997"
Application.ScreenUpdating = False
Set Ws = Sheets("Saisie_masse_1453_SIRH")
Chemin = ThisWorkbook.Path & Application.PathSeparator
Fichier = "Saisie_masse_1453_SIRH.xlsx"
If Dir(Chemin & Fichier) = "" Then
Ws.Visible = xlSheetVisible
Ws.Copy
Ws.Visible = xlSheetHidden
ActiveSheet.DrawingObjects.Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
Else
NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
If NbLg > 1 Then
With Workbooks.Open(Chemin & Fichier)
Ws.Range("A2:D" & NbLg).Copy .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Close savechanges:=True
End With
End If
End If
ActiveWorkbook.Protect Password:="200997"
End Sub
J'ai trouvé, si cela peut servir un jour à quelqu'un.
J'ai rajouté cette ligne de code :
If Ws.Range("A2") = "" Then Exit Sub
Dans :
Sub InjectionGlobal_1453()
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim NbLg As Long
ActiveWorkbook.Unprotect Password:="200997"
Application.ScreenUpdating = False
Set Ws = Sheets("Saisie_masse_1453_SIRH")
If Ws.Range("A2") = "" Then Exit Sub
Chemin = ThisWorkbook.Path & Application.PathSeparator
Fichier = "Saisie_masse_1453_SIRH.xlsx"
If Dir(Chemin & Fichier) = "" Then
Ws.Visible = xlSheetVisible
Ws.Copy
Ws.Visible = xlSheetHidden
ActiveSheet.DrawingObjects.Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
Else
NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
If NbLg > 1 Then
With Workbooks.Open(Chemin & Fichier)
Ws.Range("A2:D" & NbLg).Copy .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Close savechanges:=True
End With
End If
End If
ActiveWorkbook.Protect Password:="200997"
End Sub
Bonne soirée
Bonsoir
je changerais ton code comme suit :
Sub Synthese_1453()
Dim NbLg As Long, Ligne As Long
Dim WsL As Worksheet, Ws As Worksheet
Dim Cel As Range, Kase As Range
Dim LesFeuilles
Dim i As Integer, Colonne As Integer
ActiveWorkbook.Unprotect Password:="200997"
Application.ScreenUpdating = False
Set Ws = Sheets("Saisie_masse_1453_SIRH")
Ws.Unprotect Password:="200997"
Ws.Range("A2:L" & Rows.Count).ClearContents
Ligne = 1
Set WsL = Sheets("Liste complète des PERS DIR")
LesFeuilles = Array("Indem horaire travail DJF")
For i = 0 To UBound(LesFeuilles)
With Sheets(LesFeuilles(i))
.Unprotect Password:="200997"
NbLg = .Range("B" & Rows.Count).End(xlUp).Row + 1
If i = 2 Then Colonne = 8 Else Colonne = 8
.Range(.Cells(17, Colonne), .Cells(NbLg, Colonne)).AutoFilter field:=1, Criteria1:=">0"
'.Range("L17:L" & NbLg).AutoFilter field:=1, Criteria1:=">0"
If Application.Subtotal(103, .Range("B18:B" & NbLg)) > 0 Then
For Each Cel In .Range("B18:B" & NbLg).SpecialCells(xlCellTypeVisible)
If Cel <> "" Then
Set Kase = WsL.Columns("A").Find(what:=Replace(Replace(Cel, " ", ""), "|", ""), LookIn:=xlValues, lookat:=xlPart)
If Not Kase Is Nothing Then
Ligne = Ligne + 1
'Récupération des données
Ws.Range("A" & Ligne) = Cel.Offset(0, 7)
Ws.Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
Ws.Range("C" & Ligne) = Cel.Offset(0, 8)
Ws.Range("D" & Ligne) = Cel.Offset(0, 9)
'Ws.Range("E" & Ligne) = Cel.Offset(0, 14)
'Ws.Range("F" & Ligne) = Cel.Offset(0, 15)
' Ws.Range("G" & Ligne) = Cel.Offset(0, 16)
' Ws.Range("H" & Ligne) = Cel.Offset(0, 17)
' Ws.Range("I" & Ligne) = Cel.Offset(0, 18)
' Ws.Range("J" & Ligne) = Cel.Offset(0, 19)
'Ws.Range("K" & Ligne) = Cel.Offset(0, 20)
'Ws.Range("L" & Ligne) = .Range("A1")
'Mise en forme des données
' Range("C2:C" & NbLg).NumberFormat = "# #0,0"
' Range("D2:D" & NbLg).NumberFormat = "0.00"
'Range("E2:E" & NbLg).NumberFormat = "0.00"
'Range("F2:F" & NbLg).NumberFormat = "# #0,0"
' Range("G2:G" & NbLg).NumberFormat = "# ##0,00"
' Range("H2:H" & NbLg).NumberFormat = "0.00"
' Range("I2:I" & NbLg).NumberFormat = "# #0,0"
' Range("J2:J" & NbLg).NumberFormat = "# ##0,00"
' Range("K2:K" & NbLg).NumberFormat = "0.00"
' Range("A2:L" & NbLg).HorizontalAlignment = xlCenter
' Range("A2:L" & NbLg).VerticalAlignment = xlCenter
'Ws.Range("A" & Ligne) = Kase
'Ws.Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
'Ws.Range("C" & Ligne) = .Range("M2")
'Ws.Range("D" & Ligne) = .Range("N3")
'Ws.Range("E" & Ligne) = CDate(.Range("E12"))
'Ws.Range("F" & Ligne) = .Cells(Cel.Row, Colonne) * 100 'Cel.Offset(0, 10)
Else
MsgBox "Code " & Cel & " introuvable"
End If
End If
Next Cel
End If
.AutoFilterMode = False
.Protect Password:="200997"
ActiveWorkbook.Protect Password:="200997"
End With
Next i
If Ws.[A65536].End(xlUp).Row > 1 Then InjectionGlobal_1453: MsgBox "Export pour SIRH HARMONIE effectué"
End Sub
Fred
Edit : le probleme de la mani-re que tu as fais ... tu as déprotégé ton classeur et il reste déverrouillé ensuite
fred
Bonsoir Fred,
Merci j'ai intégré ton code
J'ai une autre question hors sujet, peut-être pourras tu m'y répondre.
Lorsque j'utilise cette macro dans son ensemble elle me créer un fichier d'export de 333ko je trouve que cela fait gros pour un fichier avec 1 ou 2 lignes dedans.
Pour deux autres onglets, il m'exporte deux fichiers de 16ko.
Voici le code ci-dessous, cela te parle cette différence de taille de fichier à l'export ?
'Private Sub Worksheet_Activate()
'Sheets("Injection").Visible = Not Sheets("Injection").Visible
'End Sub
'Option Explicit
Sub Synthese_0667()
Dim NbLg As Long, Ligne As Long
Dim WsL As Worksheet, Ws As Worksheet
Dim Cel As Range, Kase As Range
Dim LesFeuilles
Dim i As Integer, Colonne As Integer
ActiveWorkbook.Unprotect Password:="200997"
Application.ScreenUpdating = False
Set Ws = Sheets("Prépa_inj_0667")
Ws.Unprotect Password:="200997"
Ws.Range("A2:L" & Rows.Count).ClearContents
Ligne = 1
Set WsL = Sheets("Liste complète des PERS DIR")
LesFeuilles = Array("Astreintes")
For i = 0 To UBound(LesFeuilles)
With Sheets(LesFeuilles(i))
.Unprotect Password:="200997"
NbLg = .Range("B" & Rows.Count).End(xlUp).Row + 1
If i = 2 Then Colonne = 8 Else Colonne = 12
.Range(.Cells(17, Colonne), .Cells(NbLg, Colonne)).AutoFilter field:=1, Criteria1:=">0"
'.Range("L17:L" & NbLg).AutoFilter field:=1, Criteria1:=">0"
If Application.Subtotal(103, .Range("B18:B" & NbLg)) > 0 Then
For Each Cel In .Range("B18:B" & NbLg).SpecialCells(xlCellTypeVisible)
If Cel <> "" Then
Set Kase = WsL.Columns("A").Find(what:=Replace(Replace(Cel, " ", ""), "|", ""), LookIn:=xlValues, lookat:=xlPart)
If Not Kase Is Nothing Then
Ligne = Ligne + 1
'Récupération des données
Ws.Range("A" & Ligne) = Cel.Offset(0, 11)
Ws.Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
Ws.Range("C" & Ligne) = Cel.Offset(0, 12)
Ws.Range("D" & Ligne) = Cel.Offset(0, 13)
Ws.Range("E" & Ligne) = Cel.Offset(0, 14)
Ws.Range("F" & Ligne) = Cel.Offset(0, 15)
Ws.Range("G" & Ligne) = Cel.Offset(0, 16)
Ws.Range("H" & Ligne) = Cel.Offset(0, 17)
Ws.Range("I" & Ligne) = Cel.Offset(0, 18)
Ws.Range("J" & Ligne) = Cel.Offset(0, 19)
Ws.Range("K" & Ligne) = Cel.Offset(0, 20)
'Ws.Range("L" & Ligne) = .Range("A1")
'Mise en forme des données
'Range("C17:C" & NbLg).NumberFormat = "# #0,0"
'Range("D17:D" & NbLg).NumberFormat = "# ##0,00"
'Range("E17:E" & NbLg).NumberFormat = "0.00"
'Range("F17:F" & NbLg).NumberFormat = "0"
'Range("G17:G" & NbLg).NumberFormat = "00 €"
'Range("H17:H" & NbLg).NumberFormat = "00 €"
'Range("I17:I" & NbLg).NumberFormat = "0"
'Range("J17:J" & NbLg).NumberFormat = "00 €"
'Range("K17:K" & NbLg).NumberFormat = "#,##0 $"
' Range("A17:L" & NbLg).HorizontalAlignment = xlCenter
' Range("A17:L" & NbLg).VerticalAlignment = xlCenter
'Ws.Range("A" & Ligne) = Kase
'Ws.Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
'Ws.Range("C" & Ligne) = .Range("M2")
'Ws.Range("D" & Ligne) = .Range("N3")
'Ws.Range("E" & Ligne) = CDate(.Range("E12"))
'Ws.Range("F" & Ligne) = .Cells(Cel.Row, Colonne) * 100 'Cel.Offset(0, 10)
Else
MsgBox "Code " & Cel & " introuvable"
End If
End If
Next Cel
End If
.AutoFilterMode = False
.Protect Password:="200997"
ActiveWorkbook.Protect Password:="200997"
End With
Next i
TransposerTablo_0667
End Sub
Sub TransposerTablo_0667()
Dim T(), n%, i%, j%, k%, h%
ActiveWorkbook.Unprotect Password:="200997"
With Worksheets("Prépa_inj_0667")
n = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim T(5, (n - 1) * 3)
For i = 1 To 5
T(i - 1, 0) = .Cells(1, i)
Next i
T(5, 0) = .Cells(1, 11)
For i = 2 To n
For j = 3 To 9 Step 3
If .Cells(i, j) > 0 Then
k = k + 1: T(0, k) = .Cells(i, 1): T(1, k) = .Cells(i, 2)
For h = 0 To 2
T(2 + h, k) = .Cells(i, j + h)
Next h
T(5, k) = .Cells(i, 11)
End If
Next j
Next i
End With
If k = 0 Then Exit Sub
ReDim Preserve T(5, k)
With Worksheets("Saisie_masse_0667_SIRH").Range("A1")
.CurrentRegion.Clear
With .Resize(k + 1, 5)
.Value = WorksheetFunction.Transpose(T)
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
.Rows(1).Font.Bold = True
.Columns(3).NumberFormat = "#\ #00"
.Columns(4).NumberFormat = "#\ ## 000"
.Columns(5).NumberFormat = "0.00"
.Rows(1).Columns.AutoFit
.Columns(2).AutoFit
'Tri chronologique des matricule harmonie
.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
End With
'.Worksheet.Activate
End With
InjectionGlobal_0667
ActiveWorkbook.Protect Password:="200997"
'MsgBox "Données pour l'injection exportées"
End Sub
Sub InjectionGlobal_0667()
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim NbLg As Long
ActiveWorkbook.Unprotect Password:="200997"
Application.ScreenUpdating = False
Set Ws = Sheets("Saisie_masse_0667_SIRH")
Chemin = ThisWorkbook.Path & Application.PathSeparator
Fichier = "Saisie_masse_0667_SIRH.xlsx"
If Dir(Chemin & Fichier) = "" Then
Ws.Visible = xlSheetVisible
Ws.Copy
Ws.Visible = xlSheetHidden
ActiveSheet.DrawingObjects.Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
Else
NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
If NbLg > 1 Then
With Workbooks.Open(Chemin & Fichier)
Ws.Range("A2:L" & NbLg).Copy .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Close savechanges:=True
End With
End If
End If
ActiveWorkbook.Protect Password:="200997"
End Sub
re
cela ne viens peut-etre pas (probablement pas) de cette macro, mais de ta feuille modèle que tu exporte...
cela m'est déjà arrivé de voir la même chose que toi sur des fichiers... cette différence de taille peut s'expliquer sur des mises en format spécifique d'une colonne entière alors que quelques lignes pourrais suffire, des mise en formes conditionnelles ......
poste ici ton exemple de fichier vide et j'essayerais de te dire ce qui cloche
Fred
Re,
Voici les deux fichiers, c'est frappant la différence.
voici ton fichier nettoyé....
il faut que tu remplace ta feuille modèle par celle ci....
pour info
met toi sur la cellule a6 et fait un ctr+shift+fin tu va voir qu'excel va allé jusqu'à la ligne 17490 cela veut dire que tu as des formats spécifiques jusqu’à cette ligne
en supprimant toutes ces lignes non utilisées => 15ko le fichier
et si on supprime aussi dans le gestionnaire de noms tous les noms qui sont erreur (peut-être est ce lié a ton enregistrement et que cela marche dans le fichier original
le fichier ne fait plus que 9ko
Mamamia.....
J'avais regardé les MFC mais pas les gestionnaires de noms
Allez je me jette dessus !
Merci et bonne nuit.
c'est déjà bien de se poser la question de pourquoi la taille de mon fichier est trop grosse...
et surtout
merci
Fred