La solution de Lance fonctionnera dans la majorité des situations. Toutefois, si vous traitez des feuilles de calcul volumineuses/complexes, vous risquez de rencontrer le "SpecialCells Problem". En un mot, si la plage créée provoque plus de 8192 zones non contiguës (et peut peut arriver) alors Excel va lancer une erreur lorsque vous essayez d'accéder à SpecialCells et votre code ne s'exécutera pas. Si vos feuilles de calcul sont suffisamment complexes, vous vous attendez à rencontrer ce problème, alors il est recommandé de s'en tenir à l'approche en boucle.
Il convient de noter que ce problème ne concerne pas la propriété SpecialCells elle-même, mais plutôt l'objet Range. Cela signifie qu'à chaque fois que vous essayez d'obtenir un objet Range qui peut être très complexe, vous devez soit utiliser un gestionnaire d'erreur, soit faire comme vous l'avez déjà fait, pour que votre programme fonctionne sur chaque élément de la gamme (diviser le Aller jusqu'à).
Une autre approche possible consisterait à renvoyer un tableau d'objets Range, puis à parcourir le tableau. J'ai posté un exemple de code pour jouer avec. Cependant, il convient de noter que vous ne devriez vraiment vous en préoccuper que si vous pensez avoir le problème décrit ou si vous voulez simplement vous assurer que votre code est robuste. Sinon, c'est juste une complexité inutile.
Option Explicit
Public Declare Function GetTickCount Lib "kernel32"() As Long
Public Sub GenerateProblem()
'Run this to set up an example spreadsheet:
Dim row As Long
Excel.Application.EnableEvents = False
Sheet1.AutoFilterMode = False
Sheet1.UsedRange.Delete
For row = 1 To (8192& * 4&) + 1&
If row Mod 3& Then If Int(10& * Rnd) 7& Then Sheet1.Cells(row, 1&).value = "test"
Next
Sheet1.UsedRange.AutoFilter 1&, ""
Excel.Application.EnableEvents = True
MsgBox Sheet1.UsedRange.SpecialCells(xlCellTypeVisible).address
End Sub
Public Sub FixProblem()
'Run this to see various solutions:
Dim ranges() As Excel.Range
Dim index As Long
Dim address As String
Dim startTime As Long
Dim endTime As Long
'Get range array.
ranges = GetVisibleRows
'Do something with individual range objects.
For index = LBound(ranges) To UBound(ranges)
ranges(index).Interior.ColorIndex = Int(56 * Rnd + 1)
Next
'Get total address if you want it:
startTime = GetTickCount
address = RangeArrayAddress(ranges)
endTime = GetTickCount
Debug.Print endTime - startTime, ; 'Outputs time elapsed in milliseconds.
'Small demo of why I used a string builder. Straight concatenation is about
'10 times slower:
startTime = GetTickCount
address = RangeArrayAddress2(ranges)
endTime = GetTickCount
Debug.Print endTime - startTime
End Sub
Public Function GetVisibleRows(Optional ByVal ws As Excel.Worksheet) As Excel.Range()
Const increment As Long = 1000&
Dim max As Long
Dim row As Long
Dim returnVal() As Excel.Range
Dim startRow As Long
Dim index As Long
If ws Is Nothing Then Set ws = Excel.ActiveSheet
max = increment
ReDim returnVal(max) As Excel.Range
For row = ws.UsedRange.row To ws.UsedRange.Rows.Count
If Sheet1.Rows(row).Hidden Then
If startRow 0& Then
Set returnVal(index) = ws.Rows(startRow & ":" & (row - 1&))
index = index + 1&
If index > max Then
'Redimming in large increments is an optimization trick.
max = max + increment
ReDim Preserve returnVal(max) As Excel.Range
End If
startRow = 0&
End If
ElseIf startRow = 0& Then startRow = row
End If
Next
ReDim Preserve returnVal(index - 1&) As Excel.Range
GetVisibleRows = returnVal
End Function
Public Function RangeArrayAddress(ByRef value() As Excel.Range, Optional lowerindexRV As Variant, Optional upperindexRV As Variant) As String
'Parameters left as variants to allow for "IsMissing" values.
'Code uses bytearray string building methods to run faster.
Const incrementChars As Long = 1000&
Const unicodeWidth As Long = 2&
Const comma As Long = 44&
Dim increment As Long
Dim max As Long
Dim index As Long
Dim returnVal() As Byte
Dim address() As Byte
Dim indexRV As Long
Dim char As Long
increment = incrementChars * unicodeWidth 'Double for unicode.
max = increment - 1& 'Offset for array.
ReDim returnVal(max) As Byte
If IsMissing(lowerindexRV) Then lowerindexRV = LBound(value)
If IsMissing(upperindexRV) Then upperindexRV = UBound(value)
For index = lowerindexRV To upperindexRV
address = value(index).address
For char = 0& To UBound(address) Step unicodeWidth
returnVal(indexRV) = address(char)
indexRV = indexRV + unicodeWidth
If indexRV > max Then
max = max + increment
ReDim Preserve returnVal(max) As Byte
End If
Next
returnVal(indexRV) = comma
indexRV = indexRV + unicodeWidth
If indexRV > max Then
max = max + increment
ReDim Preserve returnVal(max) As Byte
End If
Next
ReDim Preserve returnVal(indexRV - 1&) As Byte
RangeArrayAddress = returnVal
End Function
Public Function RangeArrayAddress2(ByRef value() As Excel.Range, Optional lowerIndex As Variant, Optional upperIndex As Variant) As String
'Parameters left as variants to allow for "IsMissing" values.
'Code uses bytearray string building methods to run faster.
Const incrementChars As Long = 1000&
Const unicodeWidth As Long = 2&
Dim increment As Long
Dim max As Long
Dim returnVal As String
Dim index As Long
increment = incrementChars * unicodeWidth 'Double for unicode.
max = increment - 1& 'Offset for array.
If IsMissing(lowerIndex) Then lowerIndex = LBound(value)
If IsMissing(upperIndex) Then upperIndex = UBound(value)
For index = lowerIndex To upperIndex
returnVal = returnVal & (value(index).address & ",")
Next
RangeArrayAddress2 = returnVal
End Function
merci. il fonctionne dans Excel 2007. Va vérifier dans Excel 2003 tommorow –