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
| Sub test()
Dim a As Range
Set a = UsedAreas(ActiveSheet.UsedRange)
End Sub
'#####################################################################
'UsedAreas : Function that returns only the used reagions in a range
'If called without any arguments, it will return the used regions in
'the ActiveSheet.
'#####################################################################
'Author : Ejaz Ahmed
'Email : StrugglingToExcel@outlook.com
'Date : 15 June 2014
'Website : https://strugglingtoexcel.wordpress.com/
'#####################################################################
Function UsedAreas(Optional ByRef WhichRange As Range) _
As Range
'Declare Runction level Variables and Objects
Dim ConstantsRange As Range 'Stores all the cells that have values
Dim FormulaRange As Range 'Stores all the cells that have formula
Dim UsedRange As Range 'Stores Used Area
Dim ContentRange As Range 'Includes Used Area's CurrentRegion
Dim EachArea As Range 'Used in the Loop
'If the user did not pass any range to the function, use the
'sheet's used range.
If WhichRange Is Nothing Then
Set WhichRange = Application.ActiveSheet.UsedRange
End If
'The SpecialCells Method includes the entire sheet's UsedRange
'if called from a single cell. So only proceed if the user selected
'more than one cell
If WhichRange.Count > 1 Then
'Ignore the errors produced if there are no cells with Formula
'or Constants
On Error Resume Next
Set ConstantsRange = WhichRange.SpecialCells(xlCellTypeConstants)
Set FormulaRange = WhichRange.SpecialCells(xlCellTypeFormulas)
Err.Clear
On Error GoTo 0
'Combine both the Ranges together
If Not ConstantsRange Is Nothing Then
Set UsedRange = ConstantsRange
End If
If Not FormulaRange Is Nothing Then
If UsedRange Is Nothing Then
Set UsedRange = FormulaRange
Else
Set UsedRange = Application.Union( _
UsedRange, FormulaRange)
End If
End If
'We dont need these ranges anymore, forget them to save memory
Set FormulaRange = Nothing
Set ContentRange = Nothing
'We already have all the cells that have stuff in them, but there
'may be blank cells that are actually part of a table, but do not
'contain data. Therefore, we loop through the areas and include the
'current regions
If Not UsedRange Is Nothing Then
'Set the Final Range to the first Area, so we dont have to check
'if it is not empty later in the loop
Set ContentRange = UsedRange.Cells(1, 1).CurrentRegion
For Each EachArea In UsedRange.Areas
'Check if the Area is already in the Final Range
If Application.Intersect(EachArea, ContentRange) _
Is Nothing Then
'Include its current region if it is not already in the
'final range
Set ContentRange = Application.Union( _
ContentRange, EachArea.CurrentRegion)
End If
Next EachArea
End If
End If
'If the selection had used areas, return it, or
'just return the Range that was passed to the function
If ContentRange Is Nothing Then
Set UsedAreas = WhichRange
Else
Set UsedAreas = ContentRange
End If
End Function |
re
: ça peut servir aux autres 
Répondre avec citation
Envoyé par patricktoulon
J'avais "testé" avec une feuille vide … 
Partager