Exportation conditionnelle vers Word après filtrage

[Coyote34]

Bonsoir à tous,
Je suis en train de travailler sur un modèle de Bordereau de prix sous Excel :

Cijoint.fr - Service gratuit de dépôt de fichiers

je vous en explique brièvement le fonctionnement :
-Avec l'aide du forum (merci à tous!) j'ai pu créer des options de filtrage d'affichage suivant qu'une Quantité est renseignée ou non (cf Test 1.xls, bouton "Fonctions").

-chaque prestation a son descriptif correspondant dans la ligne du dessous (sur fond rose) et l'affichage est géré par le mode Plan et le formulaire du bouton "Fonctions".

Tout cela fonctionne à peu près correctement mais je voudrais savoir s'il est possible :

-de créer un nouvel onglet sous Excel en recopiant uniquement les données après filtrage du bouton "DQE filtré" du formulaire. Autrement dit obtenir dans cet onglet un tableau "propre" sans les lignes vides masqués (tout en conservant les formules si possible).

-ensuite je souhaiterai pouvoir exporter vers word les données filtrées des descriptifs pour obtenir au final un fichier word tel que celui qui est joint (Test 1.doc).

Et sur ces 2 points je cale sévère...
Voili voilou.

Merci d'avance pour votre aide.
Bon réveillon !!!

 

[PMO2]

Re : Exportation conditionnelle vers Word après filtrage

Bonjour,

Une piste avec le code suivant à copier dans un module standard.
La constante Const FEUILLE_SOURCE As String = "LOT 1" est à adapter à votre usage.
Je me suis référé à vos fichiers exemples.
La construction du document Word n'est pas parfaite mais le travail est grandement avancé.

'### Constante à adapter ###
Const FEUILLE_SOURCE As String = "LOT 1"
'###########################

Sub PMO_ExportWord()
Dim S As Worksheet
Dim DEST As Worksheet
Dim SH As Shape
Set S = Sheets(FEUILLE_SOURCE)
Application.ScreenUpdating = False
S.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Set DEST = Sheets.Add(after:=Sheets(S.Index))
DEST.Paste
Application.CutCopyMode = False
Selection.ClearOutline
DEST.[a1].Select
For Each SH In DEST.Shapes
  SH.Delete
Next SH
Call MakeDoc
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur " & Err.Number & _
  vbCrLf & Err.Description
End Sub

Sub MakeDoc(Optional dummy As Byte)
Dim var
Dim g&
Dim i&
Dim j&
Dim nbChar&
Dim A$
Dim B$
Dim X
Dim Y
Dim WA As Object  'Word.Application
Dim DOC As Object 'Word.Document
On Error GoTo Erreur
X = vbCrLf
Y = Chr(11)
var = ActiveSheet.Range("a1:e" & ActiveSheet.[e65536].End(xlUp).Row & "")
Set WA = CreateObject("Word.application")
Set DOC = WA.Documents.Add
With DOC.PageSetup
  .TopMargin = WA.CentimetersToPoints(0.75)
  .BottomMargin = WA.CentimetersToPoints(1.75)
  .LeftMargin = WA.CentimetersToPoints(0.7)
  .RightMargin = WA.CentimetersToPoints(1)
End With
For i& = 6 To UBound(var, 1)
  For j& = 1 To UBound(var, 2)
    B$ = var(i&, j&)
    If InStr(1, B$, Chr(10)) > 0 Then
      B$ = Replace(B$, Chr(10), Y)
      var(i&, j&) = B$
    End If
  Next j&
Next i&
For i& = 6 To UBound(var, 1)
  B$ = ""
  For j& = 1 To 3
    B$ = B$ & var(i&, j&)
  Next j&
  nbChar& = Len(B$)
  Select Case nbChar&
    Case 1
      A$ = X & Y & "- CHAPITRE  " & var(i&, 1) & " -" & Y & Y & _
      var(i&, 5) & Y
      WA.Selection.typetext A$
      DOC.ActiveWindow.Selection.TypeParagraph
      With DOC.Paragraphs(DOC.Paragraphs.Count - 1).Range
        With .ParagraphFormat
          .LeftIndent = WA.CentimetersToPoints(5.5)
          .RightIndent = WA.CentimetersToPoints(4.27)
          .Alignment = 1  'wdAlignParagraphCenter
          For g& = -4 To -1
            With .Borders(g&)
              .LineStyle = 7  'wdLineStyleDouble
              .LineWidth = 4  'wdLineWidth050pt
            End With
          Next g&
        End With
      End With
      A$ = ""
    Case 2
      A$ = X & var(i&, 1) & "." & var(i&, 2) & " - " & var(i&, 5)
      WA.Selection.typetext A$
      DOC.ActiveWindow.Selection.TypeParagraph
      With DOC.Paragraphs(DOC.Paragraphs.Count - 1).Range
        With .ParagraphFormat
          .LeftIndent = WA.CentimetersToPoints(2)
          .RightIndent = WA.CentimetersToPoints(0.5)
        End With
        .Font.Bold = True
      End With
      A$ = ""
    Case 3
      A$ = var(i&, 1) & "." & var(i&, 2) & "." & var(i&, 3) & ". " & _
      var(i&, 5)
      DOC.ActiveWindow.Selection.TypeParagraph
      WA.Selection.typetext A$
      With DOC.Paragraphs(DOC.Paragraphs.Count).Range
        With .ParagraphFormat
          .LeftIndent = WA.CentimetersToPoints(2)
          .RightIndent = WA.CentimetersToPoints(0.5)
        End With
        .Font.Bold = True
      End With
      DOC.ActiveWindow.Selection.TypeParagraph
      A$ = ""
    Case Else
      If var(i&, 5) <> "" Then _
            A$ = var(i&, 5) & Y & Y
      WA.Selection.typetext A$
      With DOC.Paragraphs(DOC.Paragraphs.Count).Range
        .Font.Bold = False
      End With
      DOC.ActiveWindow.Selection.TypeParagraph
      A$ = ""
  End Select
Next i&
DOC.ActiveWindow.Selection.WholeStory
Selection.Font.Name = "Arial"
DOC.Range(1, 1).Select
WA.Visible = True
Exit Sub
Erreur:
If Err <> 0 Then MsgBox "Erreur " & Err.Number & _
  vbCrLf & Err.Description & vbCrLf & "Procédure MakeDoc"
End Sub

Faites un test sur une COPIE de votre classeur en lançant la macro "PMO_ExportWord".

Cordialement.

PMO
Patrick Morange

 

[Coyote34]

Re : Exportation conditionnelle vers Word après filtrage

Merci Patrick d'avoir pris le temps de te pencher sur mon problème.

Je vais tester ton code en essayant de le comprendre pas à pas.

Je te tiens au courant.