Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 259 lines (195 sloc) 8.533 kb
5b3a55f @emilefyon Work on the LIB_Workbook file
authored
1 Attribute VB_Name = "LIB_Workbook"
2 '---------------------------------------------------------------------------------------------------------------------------------------------
3 '
4 ' Workbook Library v0.1
5 '
6 '
7 ' Dependencies
8 ' ------------
9 '
10 ' + LIB_Worksheet
11 ' + LIB_Regex
12 '
13 '
14 '
15 '
16 ' Functions lists
17 ' ---------------
18 '
19 ' + Function writeFile (ByVal file As String, ByVal content As String) As String : overwrite the content specified in the file specified.
20 ' * Specifications / limitations
21 ' - If the file does not exists, the file is created
22 ' - The folder has to exist
23 ' * Arguments
24 ' - file as String : the full path of the file
25 ' - content as String : the content that has to be written into the file
26 '
27 ' Revisions history
28 ' -----------------
29 ' - Emile Fyon 11/07/2012 v0.1 Creation
30 '
31 '---------------------------------------------------------------------------------------------------------------------------------------------
32
33
34
35
36 '---------------------------------------------------------------------------------------------------------------------------------------------
37 ' + Function getCurrentWorkbookPath() As String
38 ' * Description : Return the path of the current workbook
39 ' * Specifications / limitations
40 ' - None
41 ' * Arguments
42 ' - None
43 '
44 '
45 ' Last edition date : 11/07/2012
46 '
47 ' Revisions history
48 ' -----------------
49 ' - Emile Fyon 11/07/2012 Creation
50 '
51 '---------------------------------------------------------------------------------------------------------------------------------------------
52
53 Function getCurrentWorkbookPath()
54
55 getCurrentWorkbookPath = checkFolder(ActiveWorkbook.Path)
56
57 End Function
58
59
60
61 '---------------------------------------------------------------------------------------------------------------------------------------------
3691ddf @emilefyon Doc update
authored
62 ' + Function moveSheetsInCurrentWorkbook(ByVal wkFullPath As String, Optional ByVal namePattern As String) As String
5b3a55f @emilefyon Work on the LIB_Workbook file
authored
63 ' * Description : Return the path of the current workbook
64 ' * Specifications / limitations
65 ' - None
66 ' * Arguments
3691ddf @emilefyon Doc update
authored
67 ' - wkFullPath : the fullPath of the workbook to import the worksheets from
68 ' - namePattern : a custom name Pattern
69 ' #wkName will be replaced is with the name of the destination workbook
70 ' #wsName will be the current name of the worksheet
5b3a55f @emilefyon Work on the LIB_Workbook file
authored
71 '
72 '
73 ' Last edition date : 11/07/2012
74 '
75 ' Revisions history
76 ' -----------------
77 ' - Emile Fyon 11/07/2012 Creation
3691ddf @emilefyon Doc update
authored
78 ' - Emile Fyon 02/09/2012 Revision in order to make the function ActiveCell-free
5b3a55f @emilefyon Work on the LIB_Workbook file
authored
79 '
80 '---------------------------------------------------------------------------------------------------------------------------------------------
81
82 Sub moveSheetsInCurrentWorkbook(ByVal wkFullPath As String, Optional ByVal namePattern As String)
83 Dim wkFileName As String
84 Dim wsCurrent As Worksheet
85 Dim wk As Workbook
86 Dim BkName As String
87 Dim NumSht As Integer
88 Dim BegSht As Integer
89
90 wkFileName = fileNameFromFullPath(wkFullPath)
91
92 Set wsCurrent = ActiveSheet
93
94 Workbooks.Open Filename:=wkFullPath
95 Set wk = Workbooks(wkFileName)
96
97 For Each ws In wk.Worksheets
98 If IsMissing(namePattern) = False Then
99 ws.Name = Replace(ws.Name, "#wsName", ws.Name)
100 ws.Name = Replace(ws.Name, "#wkName", wk.Name)
101 End If
102 ws.Move After:=wsCurrent
103 Next
104
105 wsCurrent.Select
106 'Moves second sheet in source to front of designated workbook.
107 'Workbooks(cell.Value).Sheets(BegSht).Move _
108 ' Before:=Workbooks("Test.xls").Sheets(1)
109 'In each loop, the next sheet in line becomes indexed as number 2.
110 'Replace Test.xls with the full name of the target workbook you want.
111 End Sub
112
113
114
115
116
117
118 '
119
120 Function getSheetNameRedo(ByVal pattern As String, ByVal ws As Worksheet, ByVal wk As Workbook) As String
121
122 'r = ActiveCell.Value
123 'Set ws = ActiveSheet
124
125 sheetName = pattern
126 With CreateObject("vbscript.regexp")
127 .pattern = "\$(.+?)\$"
128 .Global = True
129 If .test(pattern) Then
130 For Each s In .Execute(pattern)
131 ' MsgBox (s)
132 cellAddress = Replace(s, "$", "")
133 sheetName = Replace(sheetName, s, ws.Range(cellAddress).text)
134 ' r = Replace(r, s, Replace(s, ",", "#"))
135 Next 'extractBrackets = .Execute(r)(0)
136 End If
137 End With
138 sheetName = Replace(sheetName, "#wsName", ws.Name)
139 sheetName = Replace(sheetName, "#wkName", wk.Name)
140 If sheetName = pattern Then sheetName = pattern & " " & ws.Name
141 'MsgBox (r)
142
143
144
145 getSheetName = Left(sheetName, 31)
146
147 End Function
148
149
150
151
152 Sub getReplacementPatterns()
153
154 ActiveCell.Offset(0, 0) = "$A1$"
155 ActiveCell.Offset(0, 1) = "Value of cell A1 in worksheet"
156
157 ActiveCell.Offset(1, 0) = "#wsName"
158 ActiveCell.Offset(1, 1) = "Name of the worksheet"
159
160 ActiveCell.Offset(2, 0) = "#wkName"
161 ActiveCell.Offset(2, 1) = "Name of the workbook"
162
163 ActiveCell.Offset(3, 0) = "The worksheet name will be automatically trimed to the first 31 characters"
164 ActiveCell.Offset(4, 0) = "If you don't use any pattern, the value will be used as a prefix for the new sheet name"
165
166
167
168 End Sub
169
3691ddf @emilefyon Doc update
authored
170 '---------------------------------------------------------------------------------------------------------------------------------------------
171 ' + Function listSheets() As String
172 ' * Description : Write the name of the worksheets of the current workbook in a destination cell
173 ' * Specifications / limitations
174 ' - None
175 ' * Arguments
176 ' - wkFullPath : the fullPath of the workbook to import the worksheets from
177 ' - namePattern : a custom name Pattern
178 ' #wkName will be replaced is with the name of the destination workbook
179 ' #wsName will be the current name of the worksheet
180 '
181 '
182 ' Last edition date : 11/07/2012
183 '
184 ' Revisions history
185 ' -----------------
186 ' - Emile Fyon 11/07/2012 Creation
187 ' - Emile Fyon 02/09/2012 Revision in order to make the function ActiveCell-free
188 '
189 '---------------------------------------------------------------------------------------------------------------------------------------------
190
5b3a55f @emilefyon Work on the LIB_Workbook file
authored
191
3691ddf @emilefyon Doc update
authored
192 Sub listSheets(Optional ByVal destRg As Range)
5b3a55f @emilefyon Work on the LIB_Workbook file
authored
193
194 Dim rg As Range
195
3691ddf @emilefyon Doc update
authored
196 If IsMissing(destRg) Then
197 Do
198 Set rg = Application.InputBox(Prompt:="Where do you want to copy the list of sheets ?", Title:="Choose a range", Type:=8)
199 Loop While rg Is Nothing
200 End If
5b3a55f @emilefyon Work on the LIB_Workbook file
authored
201
202 i = 0
203 For Each ws In ActiveWorkbook.Sheets
204 rg.Offset(i, 0).Value = ws.Name
205 i = i + 1
206 Next
207
208 End Sub
209
210 Sub copySheets()
211
212 Set ws = ActiveSheet
213 For Each cell In Selection
214 ws.Copy After:=ws
215 Sheets(ws.Index + 1).Name = cell.Value
216 Next
217
218 End Sub
219
220
221
222 Sub renameSheets()
223
224 For Each cell In Selection
225 Sheets(cell.Value).Name = cell.Offset(0, 1).Value
226 Next
227
228 End Sub
229
230 Sub concatenateSheets()
231
232 Set cell = ActiveCell
233
234 Set wsExtract = Sheets(cell.Value)
235 wsExtract.cells.ClearContents
236
237 For Each cell In Range(cell.Offset(1, 0), cell.End(xlDown))
238 If wsExtract.Range("A1").Value = "" Then
239 Set extractStart = wsExtract.Range("A1")
240 Else
241 Set extractStart = wsExtract.Range("A1").End(xlDown).Offset(1, 0)
242 End If
243 Set ws = Sheets(cell.Value)
244 Range(ws.Range("A1"), ws.Range("A1").End(xlToRight).End(xlDown)).Copy
245 wsExtract.Activate
246 If wsExtract.Range("A1") = "" Then
247 Set pasteCell = wsExtract.Range("A1")
248 Else
249 Set pasteCell = wsExtract.Range("A1").End(xlDown).Offset(1, 0)
250 End If
251 pasteCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
252 :=False, Transpose:=False
253
254 Next
255
256 End Sub
257
258
Something went wrong with that request. Please try again.