G
Guest
Hi,
In setting up a unique list of codes, I used a one formula
"=IF(COUNTIF(MasterData!$K$2:I4,MasterData!I4)=1,MasterData!I4,"") "
in an adjacent column relative to the original list. This gave me my unique
values, but it left blanks in between unique values.
I then used an array formula
"{=NOBLANKS_1(L2:L20000)} "
coupled with VBA code to get rid of the blanks. Here's the VBA code:
Option Explicit
Option Compare Text
Function NoBlanks_1(ITBGrp_Range1 As Range) As Variant()
Dim N As Long
Dim N2 As Long
Dim Rng As Range
Dim MaxCells As Long
Dim Result() As Variant
Dim R As Long
Dim C As Long
If (ITBGrp_Range1.Rows.Count > 1) And _
(ITBGrp_Range1.Columns.Count > 1) Then
ReDim Result(1 To ITBGrp_Range1.Rows.Count, 1 To
ITBGrp_Range1.Columns.Count)
For R = 1 To UBound(Result, 1)
For C = 1 To UBound(Result, 2)
Result(R, C) = CVErr(xlErrRef)
Next C
Next R
NoBlanks_1 = Result
Exit Function
End If
If (Application.Caller.Rows.Count > 1) And _
(Application.Caller.Columns.Count > 1) Then
ReDim Result(1 To Application.Caller.Rows.Count, 1 To
Application.Caller.Columns.Count)
For R = 1 To UBound(Result, 1)
For C = 1 To UBound(Result, 2)
Result(R, C) = CVErr(xlErrRef)
Next C
Next R
NoBlanks_1 = Result
Exit Function
End If
MaxCells = Application.WorksheetFunction.Max( _
Application.Caller.Cells.Count, ITBGrp_Range1.Cells.Count)
ReDim Result(1 To MaxCells, 1 To 1)
For Each Rng In ITBGrp_Range1.Cells
If Rng.Value <> vbNullString Then
N = N + 1
Result(N, 1) = Rng.Value
End If
Next Rng
For N2 = N + 1 To MaxCells
Result(N2, 1) = vbNullString
Next N2
If Application.Caller.Rows.Count = 1 Then
NoBlanks_1 = Application.Transpose(Result)
Else
NoBlanks_1 = Result
End If
End Function
It's made my worksheet rather unwieldy... can anyone suggest a more
efficient method? Thanks.
In setting up a unique list of codes, I used a one formula
"=IF(COUNTIF(MasterData!$K$2:I4,MasterData!I4)=1,MasterData!I4,"") "
in an adjacent column relative to the original list. This gave me my unique
values, but it left blanks in between unique values.
I then used an array formula
"{=NOBLANKS_1(L2:L20000)} "
coupled with VBA code to get rid of the blanks. Here's the VBA code:
Option Explicit
Option Compare Text
Function NoBlanks_1(ITBGrp_Range1 As Range) As Variant()
Dim N As Long
Dim N2 As Long
Dim Rng As Range
Dim MaxCells As Long
Dim Result() As Variant
Dim R As Long
Dim C As Long
If (ITBGrp_Range1.Rows.Count > 1) And _
(ITBGrp_Range1.Columns.Count > 1) Then
ReDim Result(1 To ITBGrp_Range1.Rows.Count, 1 To
ITBGrp_Range1.Columns.Count)
For R = 1 To UBound(Result, 1)
For C = 1 To UBound(Result, 2)
Result(R, C) = CVErr(xlErrRef)
Next C
Next R
NoBlanks_1 = Result
Exit Function
End If
If (Application.Caller.Rows.Count > 1) And _
(Application.Caller.Columns.Count > 1) Then
ReDim Result(1 To Application.Caller.Rows.Count, 1 To
Application.Caller.Columns.Count)
For R = 1 To UBound(Result, 1)
For C = 1 To UBound(Result, 2)
Result(R, C) = CVErr(xlErrRef)
Next C
Next R
NoBlanks_1 = Result
Exit Function
End If
MaxCells = Application.WorksheetFunction.Max( _
Application.Caller.Cells.Count, ITBGrp_Range1.Cells.Count)
ReDim Result(1 To MaxCells, 1 To 1)
For Each Rng In ITBGrp_Range1.Cells
If Rng.Value <> vbNullString Then
N = N + 1
Result(N, 1) = Rng.Value
End If
Next Rng
For N2 = N + 1 To MaxCells
Result(N2, 1) = vbNullString
Next N2
If Application.Caller.Rows.Count = 1 Then
NoBlanks_1 = Application.Transpose(Result)
Else
NoBlanks_1 = Result
End If
End Function
It's made my worksheet rather unwieldy... can anyone suggest a more
efficient method? Thanks.