urgent - changing a range

[david shapiro]

Hi,

A bit urgent - Does anyone know why this isn`t working? The code is to
do an advanced filter taking the full range of data in a worksheet? If
possible, I`d like to alter it to put the results of the filter in a new
sheet. Thanks.

Dave

"source data" - the main file which is being filtered from.
"criteria file" - the criteria for the filter


Dim rngData As Range, RngCrit As Range
Dim rngOutput As Range

With ActiveWorkbook
With .Sheets("source data")
Set rngData = .Range("A1").CurrentRegion ' End With

With .Sheets("criteria file")
Set RngCrit = .Range("A1").CurrentRegion '
Set rngOutput = .Range("A1")
End With

.Sheets("criteria file").Activate
rngData.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=RngCrit, _
CopyToRange:=rngOutput, _
Unique:=True
End With

 

[Norman Jones]

Hi David,

Setting your criteria range to:

Set RngCrit = .Range("A1").CurrentRegion '

means that the filter criteria will be overwritten by your extracted data.

You should, therefore move the criteria range away from your output range.

Additionally, you should clear your output range between filter operations.

Using H1 on the criteria file sheet as the anchor cell for the criteria
range, your code might read as:

Sub Tester()
Dim rngData As Range, RngCrit As Range
Dim rngOutput As Range

With ActiveWorkbook
With .Sheets("source data")
Set rngData = .Range("A1").CurrentRegion '
End With

With .Sheets("criteria file")
Set RngCrit = .Range("H1").CurrentRegion '
Set rngOutput = .Range("A1")
End With

.Sheets("criteria file").Activate
rngOutput.CurrentRegion.ClearContents
rngData.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=RngCrit, _
CopyToRange:=rngOutput, _
Unique:=True
End With

End Sub

Change H1 to a convenient location non-contiguous to the output range.

 

[david shapiro]

Norman and others,

Thanks for the new suggestion on changing the range in an advanced
filter. I`ll try that.

I`m wondering - it`s rather urgent, under deadline today very soon - I`m
coming up with an error in this code. Could you take a look at it and,
if possible, check the whole code for any bugs.

The first error that comes up is in the sub standardizeyears. It stops
at the word "match" in the following line, and says "compile error: sub
or function not defined".

Do Until Cells(intRowx + 1, intCol).value = "" ' Loop until end of
data
If Match(Cells(intRowx, intCol).value, years, 0) = "#N/A" Then
Call nonstandardyear(intRowx, intCol)

This is the whole code. Sorry about the rush. Thanks, would be much
appreciated. -- Dave

Sub preparationfinaldata()
Call standardizeyears
Call standardizesubgroup
End Sub
Sub standardizeyears()
Dim intRowx
Dim intCol
Dim years As Integer

intRowx = 1 ' Start in the first row
intCol = 2 ' The column in "final data" that contains the Years
to check

'Create a reference in the Standards Worksheet called "Years" for
the year columns
Do Until Cells(intRowx + 1, intCol).value = "" ' Loop until end of
data
If Match(Cells(intRowx, intCol).value, years, 0) = "#N/A" Then
Call nonstandardyear(intRowx, intCol)
End If
intRowx = intRowx + 1 ' Increment to next row
Loop
End Sub
Sub nonstandardyear(r As Integer, c As Integer)
Dim intLastCol
Dim intYear

intLastCol = 6 'Last nonempty column of excel sheet
intYear = Cells(r, c).value
Select Case Val(Cells(r, c).value)
Case 1990 To 1999
Cells(r, c).value = VLookup(mround(Cells(r, c).value, 5),
years, 1, False)
Case Else
Cells(r, c).value = VLookup(mround(Cells(r, c).value, 10),
years, 1, False)
End Select
Cells(r, intLastCol).value = "This data refers to" & intYear

End Sub
Sub standardizesubgroup()
Dim intRowx
Dim intCol

intRowx = 1 ' Start in the first row
intCol = 6 ' The column in "final data" that contains the Years
to check

'Create a reference in the Standards Worksheet called "subgroup" for
the subgroup columns
Do Until Cells(intRowx + 1, intCol).value = "" ' Loop until end of
data
If Match(Cells(intRowx, intCol).value, subgroup, 0) = "#N/A" Then
Call nonstandardsubgroup(intRowx, intCol)
End If
intRowx = intRowx + 1 ' Increment to next row
Loop
End Sub
Sub nonstandardsubgroup(r As Integer, c As Integer)
Dim strDigits As String
Dim intDigits As Integer
Dim intLastCol

intLastCol = 6

intDigits = Val(Left(Cells(rowx, col).value, 2)) + 5
strDigits = Str(intDigits)

If Cells(r, intLastCol) = "" Then
Cells(r, intLastCol) = VLookup(strDigits, subgroup, 1, True)
Else
Cells(r, intLastCol) = Cells(r, intLastCol) & VLookup(strDigits,
subgroup, 1, True)
End If


End Sub

 

[Norman Jones]

Hi Dave,

Without otherwise looking at your code, change:

Match

to

Application.Match

Match is an Excel function not a VBA function.

 

[Tom Ogilvy]

Years would need to be a named range of size single row or single column.
(or put in a valid range of this type)

Dim res as Variant
res = ApplicationMatch(Cells(intRowx, intCol).value, Range("years"), 0)
if iserror(res) then
msgbox "Not found"
else
msgbox "found at " & Range("years")(res).Address
end if

 

[david shapiro]

Thanks to Tom, Norman and others for the suggestions on the code. For
some reason, this part - changing the range on the advanced filter still
doesn`t work:

I`m new to this, how could the following code be adjusted so that:
"criteria file" - the criteria for the advanced filter

"source data" - the large dataset from which to extract

A new worksheet called "final data" is created, and the results of the
advanced filter are put there. (Please do not overwrite/change contents
of "criteria file").

The range on both the "criteria file" and "source data" should be the
whole dataset in the worksheet. Norman, I`m not quite sure what you
mean by criteria column (H). In this case, all of the columns in the
"criteria file" are criteria, so how could this whole range be put?
Would appreciate your suggestions.

Thanks. - David

Sub extractall()
Dim rngData As Range, RngCrit As Range
Dim rngOutput As Range

With ActiveWorkbook
With .Sheets("source data")
Set rngData = .Range("A1").CurrentRegion '
End With

With .Sheets("criteria file")
Set RngCrit = .Range("A1").CurrentRegion '
Set rngOutput = .Range("A1")
End With

.Sheets("criteria file").Activate
rngOutput.CurrentRegion.ClearContents
rngData.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=RngCrit, _
CopyToRange:=rngOutput, _
Unique:=True
End With

End Sub