OssieMac help with code.

P

primed

Hi,

Thanks again for the code below.
Can you please provide one small alteration. I now need the users input that
is entered into the poup box to be copied into a cell on the same page. Ie if
the user chooses 1 then 1 is then displayed in cell A1. If they select All
then "All" is displayed in cell A1.

Cheers
Primed

Sub SetMatchingTableFilters()
Dim strHeader As String
Dim lngNumbTables As Long
Dim i As Long
Dim colNumber As Long
Dim rngHeader As Range
Dim varInitCriteria As Variant
Dim varInputs As Variant

'Edit "Project" to your header name to find
strHeader = "Project"

'Edit 8 to the number total number of tables to process
lngNumbTables = 8

Call UniqueArray

For i = LBound(validArray) To UBound(validArray)
varInputs = varInputs & validArray(i) & ", "
Next i

varInputs = varInputs & "All"

'Do loop anly allows valid input.
Do
varInitCriteria = Application.InputBox _
(Prompt:="Enter the required project number." _
& vbCrLf & vbCrLf & "Valid inputs " & varInputs, _
Title:="Project Number")

If varInitCriteria = False _
Or Len(varInitCriteria) = 0 Then
MsgBox "User Cancelled " & _
"or did not make a selection." & vbCrLf & _
vbCrLf & "Processing terminated."
Exit Sub
End If

Loop While InStr(1, UCase(varInputs), _
UCase(varInitCriteria)) = 0

With ActiveSheet
'Iterate through all tables and
'find the header column number and
'then set the filters
For i = 1 To lngNumbTables

'Find the column header name
Set rngHeader = _
.Range("Table" & i & "[#Headers]") _
.Find(What:=strHeader, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

'If header name found then
'set the column header number
'(Column number in table is same
'as filter number)
If Not rngHeader Is Nothing Then
colNumber = rngHeader.Column
Else
MsgBox "No column named " & _
strHeader & " in Table" & i
Exit Sub
End If

'Set the criteria for the filter number.
'Simple filter with one selection.
If UCase(varInitCriteria) = "ALL" Then
.ListObjects("Table" & i) _
.Range.AutoFilter Field:=colNumber
Else
.ListObjects("Table" & i) _
.Range.AutoFilter Field:=colNumber, _
Criteria1:=varInitCriteria
End If
Next i

End With
End Sub
 
O

OssieMac

Immediately after the following line
Loop While InStr(1, UCase(varInputs), _
UCase(varInitCriteria)) = 0

insert the following line but edit "Sheet1" to your sheet name.

Sheets("Sheet1").Range("A") = varInitCriteria
 
O

OssieMac

My apologies that should have been Range("A1") not A

Sheets("Sheet1").Range("A1") = varInitCriteria

--
Regards,

OssieMac


OssieMac said:
Immediately after the following line
Loop While InStr(1, UCase(varInputs), _
UCase(varInitCriteria)) = 0

insert the following line but edit "Sheet1" to your sheet name.

Sheets("Sheet1").Range("A") = varInitCriteria

--
Regards,

OssieMac


primed said:
Hi,

Thanks again for the code below.
Can you please provide one small alteration. I now need the users input that
is entered into the poup box to be copied into a cell on the same page. Ie if
the user chooses 1 then 1 is then displayed in cell A1. If they select All
then "All" is displayed in cell A1.

Cheers
Primed

Sub SetMatchingTableFilters()
Dim strHeader As String
Dim lngNumbTables As Long
Dim i As Long
Dim colNumber As Long
Dim rngHeader As Range
Dim varInitCriteria As Variant
Dim varInputs As Variant

'Edit "Project" to your header name to find
strHeader = "Project"

'Edit 8 to the number total number of tables to process
lngNumbTables = 8

Call UniqueArray

For i = LBound(validArray) To UBound(validArray)
varInputs = varInputs & validArray(i) & ", "
Next i

varInputs = varInputs & "All"

'Do loop anly allows valid input.
Do
varInitCriteria = Application.InputBox _
(Prompt:="Enter the required project number." _
& vbCrLf & vbCrLf & "Valid inputs " & varInputs, _
Title:="Project Number")

If varInitCriteria = False _
Or Len(varInitCriteria) = 0 Then
MsgBox "User Cancelled " & _
"or did not make a selection." & vbCrLf & _
vbCrLf & "Processing terminated."
Exit Sub
End If

Loop While InStr(1, UCase(varInputs), _
UCase(varInitCriteria)) = 0

With ActiveSheet
'Iterate through all tables and
'find the header column number and
'then set the filters
For i = 1 To lngNumbTables

'Find the column header name
Set rngHeader = _
.Range("Table" & i & "[#Headers]") _
.Find(What:=strHeader, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

'If header name found then
'set the column header number
'(Column number in table is same
'as filter number)
If Not rngHeader Is Nothing Then
colNumber = rngHeader.Column
Else
MsgBox "No column named " & _
strHeader & " in Table" & i
Exit Sub
End If

'Set the criteria for the filter number.
'Simple filter with one selection.
If UCase(varInitCriteria) = "ALL" Then
.ListObjects("Table" & i) _
.Range.AutoFilter Field:=colNumber
Else
.ListObjects("Table" & i) _
.Range.AutoFilter Field:=colNumber, _
Criteria1:=varInitCriteria
End If
Next i

End With
End Sub
Click to expand...
Click to expand...
 
P

primed

Cheers, I just had to change "A" to "A1"


OssieMac said:
Immediately after the following line
Loop While InStr(1, UCase(varInputs), _
UCase(varInitCriteria)) = 0

insert the following line but edit "Sheet1" to your sheet name.

Sheets("Sheet1").Range("A") = varInitCriteria

--
Regards,

OssieMac


primed said:
Hi,

Thanks again for the code below.
Can you please provide one small alteration. I now need the users input that
is entered into the poup box to be copied into a cell on the same page. Ie if
the user chooses 1 then 1 is then displayed in cell A1. If they select All
then "All" is displayed in cell A1.

Cheers
Primed

Sub SetMatchingTableFilters()
Dim strHeader As String
Dim lngNumbTables As Long
Dim i As Long
Dim colNumber As Long
Dim rngHeader As Range
Dim varInitCriteria As Variant
Dim varInputs As Variant

'Edit "Project" to your header name to find
strHeader = "Project"

'Edit 8 to the number total number of tables to process
lngNumbTables = 8

Call UniqueArray

For i = LBound(validArray) To UBound(validArray)
varInputs = varInputs & validArray(i) & ", "
Next i

varInputs = varInputs & "All"

'Do loop anly allows valid input.
Do
varInitCriteria = Application.InputBox _
(Prompt:="Enter the required project number." _
& vbCrLf & vbCrLf & "Valid inputs " & varInputs, _
Title:="Project Number")

If varInitCriteria = False _
Or Len(varInitCriteria) = 0 Then
MsgBox "User Cancelled " & _
"or did not make a selection." & vbCrLf & _
vbCrLf & "Processing terminated."
Exit Sub
End If

Loop While InStr(1, UCase(varInputs), _
UCase(varInitCriteria)) = 0

With ActiveSheet
'Iterate through all tables and
'find the header column number and
'then set the filters
For i = 1 To lngNumbTables

'Find the column header name
Set rngHeader = _
.Range("Table" & i & "[#Headers]") _
.Find(What:=strHeader, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

'If header name found then
'set the column header number
'(Column number in table is same
'as filter number)
If Not rngHeader Is Nothing Then
colNumber = rngHeader.Column
Else
MsgBox "No column named " & _
strHeader & " in Table" & i
Exit Sub
End If

'Set the criteria for the filter number.
'Simple filter with one selection.
If UCase(varInitCriteria) = "ALL" Then
.ListObjects("Table" & i) _
.Range.AutoFilter Field:=colNumber
Else
.ListObjects("Table" & i) _
.Range.AutoFilter Field:=colNumber, _
Criteria1:=varInitCriteria
End If
Next i

End With
End Sub
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Excel Code does not work in Access 5
Hiding a column vs. Deleting a Column 1
Outlook Macro - Help Required 0
Excel VB to create and send an outlook appointment with html code 1
using UCase 2
Creating and transposing a multiarray 3
VBA Multiple Line handling with Split() 1
Outlook events stop work randomly 0

Top