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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
Sub Gmain_Extra_Activity_List(Document As String, Excel_Workbook As String, Excel_Script_File As String, Specific_param As Variant)
'
' Gmain_Student_List Macro
' Macro enregistrée le 26/05/2006 par Admin
'
Dim lrow As Long
Dim xlrow As String
Dim Range_Id As String
Dim Temp_Range_Id As String
Dim off As Long
Dim Column_from As String
Dim Column_to As String
Dim Start_Range_Id As String
Dim tablw() As String
Dim weeks As Single
Dim idx As Integer
Dim Sel_Range As String
Workbooks.Open Filename:=Document
Windows(Excel_Workbook).Activate
ActiveSheet.UsedRange
ActiveSheet.UsedRange
Range_Id = Get_Range_Id(ActiveSheet.UsedRange.Name)
Start_Range_Id = Range_Id
Column_from = Trim(Get_Column_From(ActiveSheet.UsedRange.Name))
Column_to = Trim(Get_Column_To(ActiveSheet.UsedRange.Name))
Range(Range_Id).Select
'**********************************************
'* real VB Script Start here *
'**********************************************
'Header Line In Bold
Range_Id = Column_from & "1:" & Column_to & "1"
Range(Range_Id).Font.Bold = True
lrow = ActiveSheet.UsedRange.Rows.Count
xlrow = lrow
'Autofit
Range_Id = Column_from & ":" & Column_to
Columns(Range_Id).EntireColumn.AutoFit
'Hide Fields
tablw = Split(Specific_param, "~") 'Specific param = Weeks_nbr
weeks = tablw(1)
'Rename Optional Activities Weeks Colums Header
Sel_Range = "D1"
For idx = 1 To weeks
With Range(Sel_Range).Offset(0, idx - 1)
.Value = "Week" & idx & " Activity"
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Next idx
'Resize Renamed Column
Range_Id = "D:L"
Columns(Range_Id).ColumnWidth = 15
'unused Week : Counter (From C))
For idx = weeks + 1 To 8
Columns(Range("C1").Column + idx).EntireColumn.Hidden = True
Next idx
'Add Border Line to delimit NAme
Range_Id = "B2:B" & xlrow
Range(Range_Id).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'Restrict Width
Columns("A:A").Select 'Category
Selection.ColumnWidth = 7
Columns("B:B").Select 'Name
Selection.ColumnWidth = 30
Columns("C:C").Select 'Age
Selection.ColumnWidth = 4.57
'Sort
Range(Start_Range_Id).Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
'Freeze panes
Range("B2").Select
ActiveWindow.FreezePanes = True
'goto A1
Range("A1").Select
ActiveWorkbook.Save
ActiveWorkbook.Close
'**********************************************
'* real VB Script Stop here *
'**********************************************
Windows(Excel_Script_File).Activate
End Sub |
[VBA] Excel dans access (utilisation d'objets excel dans access)
Répondre avec citation
Partager