1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
| Sub Extraction_Formulaire()
'à la réception du formulaire, le code ci-dessous automatise la fonction du menu Outils - Option - Formulaire : enregistrer uniquement les données
With Options
.AllowFastSave = False
.BackgroundSave = True
.CreateBackup = True
.SavePropertiesPrompt = False
.SaveInterval = 10
.SaveNormalPrompt = False
.OptimizeForWord97byDefault = False
End With
With ActiveDocument
.ReadOnlyRecommended = False
.EmbedTrueTypeFonts = False
.SaveFormsData = True
.SaveSubsetFonts = False
.Password = ""
.WritePassword = ""
.OptimizeForWord97 = False
End With
Application.DefaultSaveFormat = ""
'copier les données dans un fichier TXT
ChangeFileOpenDirectory "C:\Mes documents\"
ActiveDocument.SaveAs FileName:="Fichier.txt", FileFormat:= _
wdFormatText, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=True, SaveAsAOCELetter:= _
False
ActiveDocument.Close
'ouvre Fichier.TXT sous Excel en format délimité par des points virgule
Dim xls As Object, wkb As Excel.Workbook
Set xls = New Excel.Application
xls.Visible = True
Set wkb = xls.Workbooks.Open("C:\Mes documents\Fichier.txt")
'dans cet exemple, le formulaire comporte 27 réponses
Workbooks.OpenText FileName:= _
"C:\Mes documents\Fichier.txt" _
, Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier _
:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=True _
, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1) _
, Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15 _
, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), _
Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1))
'copie la ligne de données dans le fichier Excel qui servira de base de données puis ferme le fichier TXT
Worksheets("Base1").Activate
Rows("1:1").Select
Rows("1:1").Copy
ActiveWorkbook.Close
'ouvre le classeur Base_de_données.xls et active la feuille Base1 pour y coller la sélection
Workbooks.Open FileName:= _
"C:\Mes documents\Base_de_données.xls"
'copie la sélection sous la ligne non vide
Worksheets("base1").Activate
Range("A1").Select
Do Until ActiveCell = ""
ActiveCell.Offset(1, 0).Select
Loop
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub |
Partager