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

capture

le fichier ne fait plus que 9ko

2modele-1453.xlsx (14.30 Ko)

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

Rechercher des sujets similaires à "vba pas donnees creer fichier export"