Is there an easier way to address ranges??

[dororke]

Hi,

I've created the bit of code below to copy a row of data from
worksheets to one worksheet so that the rows are appended to each othe
and then finally sorted.

The code works fine but seems to be rather cumbersome. Is there a
easier way of addressing ranges rather than having to create/defin
them first? Any advice of my use of the other fuctions would also b
greatly appreciated.

Thanks in advance,

Dan


Sub FindUniqueBSN()
'
' FindUniqueBSN Macro

Dim WS1Name As String
Dim WS2Name As String
Dim WS3Name As String

Sheets.Add.Name = "UniqueBSNList"
WS1Name = "All Open Tickets"
WS2Name = "Tickets raised this month"
WS3Name = "Tickets closed this month"

'Set up 3 ranges for each worksheet
ActiveWorkbook.Names.Add Name:="WS1BSN", RefersToR1C1:= _
"=OFFSET('" & WS1Name & "'!R4C2,0,0,COUNTA('" & WS1Name
"'!C1)-2,1)"
ActiveWorkbook.Names.Add Name:="WS2BSN", RefersToR1C1:= _
"=OFFSET('" & WS2Name & "'!R4C2,0,0,COUNTA('" & WS2Name
"'!C1)-2,1)"
ActiveWorkbook.Names.Add Name:="WS3BSN", RefersToR1C1:= _
"=OFFSET('" & WS3Name & "'!R4C2,0,0,COUNTA('" & WS3Name
"'!C1)-2,1)"
'Copy 1st range to new worksheet
Sheets(WS1Name).Select
Range("WS1BSN").Select
Selection.Copy Sheets("UniqueBSNList").Range("B2")
'Copy 2nd range to new worksheet but at end of 1st range
Sheets(WS2Name).Select
Range("WS2BSN").Select
ActiveWorkbook.Names.Add Name:="BSNLength", RefersToR1C1:= _
"=OFFSET('UniqueBSNList'!R1C2,COUNTA('UniqueBSNList'!C2)+1,0)"
Selection.Copy Sheets("UniqueBSNList").Range("BSNLength")
'Copy 3rd range to new worksheet but at end of both previous ranges
Sheets(WS3Name).Select
Range("WS3BSN").Select
ActiveWorkbook.Names.Add Name:="BSNLength", RefersToR1C1:= _
"=OFFSET('UniqueBSNList'!R1C2,COUNTA('UniqueBSNList'!C2)+1,0)"
Selection.Copy Sheets("UniqueBSNList").Range("BSNLength")
'Select entire range then sort it
ActiveWorkbook.Names.Add Name:="BSNLength", RefersToR1C1:= _
"=OFFSET('UniqueBSNList'!R2C2,0,0,COUNTA('UniqueBSNList'!C2),1)"
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGues
_
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

End Su

 

[Dave Peterson]

I made some assumptions on how the ranges were laid out. (I bet you had some
empty cells in B1:B4 of each sheet.)

The assumption I made was that B4 contained the first real BSN and it extended
all the way down the column. (In fact, I used VBA's equivalent of going to the
bottom of column B (B65536, hitting End and then hitting the Up Arrow to find
that last used cell in that column.)

And since your routine is called FindUniqueBSN, I figured that you really wanted
a list of unique BSN with no duplicates. After you have the list of all the
BSN's in a column, you can use Data|filter|Advanced filter to copy the unique
values to another range. (That's what that last section does. It also deleted
the long list that contained the duplicates.)



Option Explicit
Sub FindUniqueBSN1()

Dim WSNames As Variant
Dim iCtr As Long
Dim myRng As Range
Dim wks As Worksheet
Dim uniqueWks As Worksheet
Dim destCell As Range

Application.DisplayAlerts = False
On Error Resume Next
Worksheets("uniquebsnList").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set uniqueWks = Worksheets.Add
With uniqueWks
.Name = "UniqueBSNList"
.Range("a1").Value = "Uniques"
End With

WSNames = Array("All Open Tickets", _
"Tickets raised this month", _
"Tickets closed this month")

'this does the copying
For iCtr = LBound(WSNames) To UBound(WSNames)
Set wks = Worksheets(WSNames(iCtr))

With uniqueWks
Set destCell = .Cells(.Rows.Count, "a").End(xlUp).Offset(1, 0)
End With

With wks
.Range("B4", .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=destCell
End With
Next iCtr

'this does the "uniquing"
With uniqueWks
.Range("a1", .Cells(.Rows.Count, "A").End(xlUp)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=.Range("b1"), Unique:=True
.Range("a1").EntireColumn.Delete
.Range("b1").EntireColumn.Sort key1:=.Range("b1"), Order1:=xlAscending,
_
Header:=xlYes, OrderCustom:=1, MatchCase:=False
End With

End Sub