Kode at virke i 3 ark istedet for hele projektmappen!!
Hej alle,jeg har følgende VB-kode som virker perfekt men problemet er at koden virker i alle ark i projektmappen. Hvordan får jeg koden kun at virke i 3 ark,og arket med navnet "09" som mainSheet?Det to andre ark hedder "10" og "11"?
Eller er det letter at implementere at koden ikke skal virke på den sheet der hedder "Menu"?!?
Det er følgende kode, som overføre de samme kriterier fra autofilter til de andre sheets:
Sub filter_All_Sheets()
Dim objSheet As Worksheet, objMAinSheet As Worksheet
Dim arrAllFilters() As String
Dim byteCountFilter As Byte, i As Byte
Set objMAinSheet = ActiveSheet
' insert all criteria and address
If insertAllFilters(arrAllFilters, byteCountFilter) Then
Application.ScreenUpdating = False
' If is allright, go on
For Each objSheet In ActiveWorkbook.Worksheets
' don't do on same sheet
If objSheet.Name <> objMAinSheet.Name Then
On Error GoTo errhandler
'check Autofilter, if one is off = switch on
objSheet.Select
If Not objSheet.AutoFilterMode Then
' if sheet doesn't contain some data
Range(arrAllFilters(4, 1)).AutoFilter
End If
' here I know that Autofilter is On
' filter some item
For i = 1 To byteCountFilter
' only 1 criteria (without Operator)
If arrAllFilters(2, i) = 0 Then
Range(arrAllFilters(4, i)).AutoFilter _
Field:=Range(arrAllFilters(4, i)).Column, _
Criteria1:=arrAllFilters(1, i)
' with operator
ElseIf arrAllFilters(2, i) <> 0 Then
Range(arrAllFilters(4, i)).AutoFilter _
Field:=Range(arrAllFilters(4, i)).Column, _
Criteria1:=arrAllFilters(1, i), _
Operator:=arrAllFilters(2, i), _
Criteria2:=arrAllFilters(3, i)
End If
Next i
End If
Next objSheet
Else
'While Main Sheet doesn't contain data or Autofilter is off
MsgBox "Main Sheet (Name """ & objMAinSheet.Name & """) doesn't some data or it doesn't use !" _
& vbCrLf & "This code can't go on.", vbCritical, "Missing Autofilter object or filter item "
Set objMAinSheet = Nothing
Set objSheet = Nothing
Application.ScreenUpdating = True
Exit Sub
End If
objMAinSheet.Activate
Set objMAinSheet = Nothing
Set objSheet = Nothing
Application.ScreenUpdating = True
MsgBox "Finished"
Exit Sub
errhandler:
Set objMAinSheet = Nothing
Set objSheet = Nothing
Application.ScreenUpdating = True
'If Err.Number = 1004 Then
'MsgBox "Probable cause of error - sheet dosn't contain some data", vbCritical, "Error Exception on sheet " & ActiveSheet.Name
'Else
'MsgBox "Sorry, run exception"
'End If
End Sub
Function insertAllFilters(arrAllFilters() As String, byteCountFilter As Byte) As Boolean
' go throught all filters and inserting their address and criterial
Dim myFilter As Filter
Dim myFilterRange As Range
Dim boolFilterOn As Boolean
Dim i As Byte, byteColumn As Byte
boolFilterOn = False: i = 0: byteColumn = 0
' If AutoFilter is off - return False
If Not ActiveSheet.AutoFilterMode Then
insertAllFilters = False
Exit Function
End If
' If Autofilter is on & no filter any item = return false
For Each myFilter In ActiveSheet.AutoFilter.Filters
If myFilter.On Then
boolFilterOn = True
Exit For
End If
Next myFilter
' Check Filter
If Not boolFilterOn Then
insertAllFilters = False
Exit Function
End If
On Error GoTo errhandler
' here is all control done
With ActiveSheet.AutoFilter
For Each myFilter In .Filters
byteColumn = byteColumn + 1
If myFilter.On Then
i = i + 1
ReDim Preserve arrAllFilters(1 To 4, 1 To i)
arrAllFilters(1, i) = myFilter.Criteria1
arrAllFilters(2, i) = myFilter.Operator
If myFilter.Operator <> 0 Then
arrAllFilters(3, i) = myFilter.Criteria2
End If
arrAllFilters(4, i) = .Range.Columns(byteColumn).Cells(1).Address
End If
Next myFilter
End With
byteCountFilter = i
insertAllFilters = True
Set myFilter = Nothing
Set myFilterRange = Nothing
Exit Function
errhandler:
insertAllFilters = False
Set myFilter = Nothing
Set myFilterRange = Nothing
End Function
