jski
New Member
I use a macro that filters on a column and makes a new worksheet for each unique value in that column. I would like to have the macro do a VLOOKUP into a named range, pull the value from the second column and then use that value to name the new worksheet after its generated. No luck. In the code below, CAList is the named range, CAName is the data in the first column of that range and CAName2 is the data in the second column which is what I'm trying to pull in.
I believe the naming of the new sheet is driven by the snippet of code:
SheetName = RTrim(Left(FilterRange.Value, 31)), which is simply using the value in the cell of the filter range.
I tried adding this and got no results:
Sheetname = Application.WorksheetFunction.VLookup(FilterRange.Value, CAList, 2, False)
I may not have have assigned a Range object to the variable CAList perhaps? I also tried this and no luck:
Sheetname = Application.VLookup(FilterRange.Value, Range("CAList"), 2, False)
Each value in the filter range is the name of an employee. What I'm actually trying to do is have the macro take the first letter of the first name, capitalize it, and then combine it with the last name. For example:
Alfred E. Neuman = ANeuman
The trick is some employees use a middle initial and some don't. I think the easiest way to do that is through VLOOKUP so I can change the table as employees come / go. Perhaps is might be easier to simply have the code do just do that from the value that is in the filtered field rather than execute a VLOOKUP? Just a thought.
------------------------------------------------------------
Option Explicit
'Generates an inputbox to select column containing desired extraction criteria'
'and creates separate tab with headings for each unique criteria found.
'Assumes headings are in row 1 of master data sheet.'
Sub FilterData()
Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
Dim Datarng As Range, FilterRange As Range, objRange As Range, CAList As Range
Dim rowcount As Long
Dim colcount As Integer, FilterCol As Integer
Dim SheetName As String
Dim wkSt As String
Dim CAName As String
Dim CAName2 As Single
Dim wkBk As Worksheet
'master sheet
Set ws1Master = ActiveSheet
'set the Column you are filtering'
top:
On Error Resume Next
Set objRange = Application.InputBox("Select One Column Only To Filter", "Range Input", , , , , , 8)
On Error GoTo 0
If objRange Is Nothing Then
Exit Sub
ElseIf objRange.Columns.Count > 1 Then
GoTo top
End If
FilterCol = objRange.Column
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error GoTo progend
'add filter sheet
Set wsFilter = Sheets.Add
With ws1Master
.Activate
.Unprotect Password:="" 'add password if needed
rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
colcount = .Cells(1, .Columns.Count).End(xlToLeft).Column
If FilterCol > colcount Then
Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
End If
Set Datarng = .Range(.Cells(1, 1), .Cells(rowcount, colcount))
'extract Unique values from FilterCol
.Range(.Cells(1, FilterCol), _
.Cells(rowcount, _
FilterCol)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wsFilter.Range("A1"), _
Unique:=True
rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
If Len(FilterRange.Value) > 0 Then
'add the FilterRange to criteria
wsFilter.Range("B2").Value = FilterRange.Value
SheetName = RTrim(Left(FilterRange.Value, 31))
'if FilterRange sheet exists
'update it
If SheetExists(SheetName) Then
Sheets(SheetName).Cells.Clear
Else
'add new sheet
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = SheetName
End If
Datarng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=Sheets(SheetName).Range("A1"), _
Unique:=False
'Freezes the top row
Application.ScreenUpdating = True
Cells(2, 1).Select
ActiveWindow.FreezePanes = True
'formats the data
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
Rows("1:1").Select
With Selection.Font
.Size = 11
Cells.Select
ActiveWindow.Zoom = 90
End With
'Applies data filters
With ActiveSheet
.AutoFilterMode = False
.Range("A1:W1").AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End With
End If
Next
.Select
End With
progend:
wsFilter.Delete
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err > 0 Then
MsgBox (Error(Err)), vbCritical, "Error"
Err.Clear
End If
'Autofits all columns in new tabs
'Application.ScreenUpdating = False
'wkSt = ActiveSheet.Name
'For Each wkBk In ActiveWorkbook.Worksheets
'On Error Resume Next
'wkBk.Activate
'Cells.EntireColumn.AutoFit
'Next wkBk
Sheets(wkSt).Select
Application.ScreenUpdating = True
End Sub
------------------------------------------------------------
I continue to be appreciative of the expertise of the forum members and their consideration in helping and educating others. Many thanks in advance.
I believe the naming of the new sheet is driven by the snippet of code:
SheetName = RTrim(Left(FilterRange.Value, 31)), which is simply using the value in the cell of the filter range.
I tried adding this and got no results:
Sheetname = Application.WorksheetFunction.VLookup(FilterRange.Value, CAList, 2, False)
I may not have have assigned a Range object to the variable CAList perhaps? I also tried this and no luck:
Sheetname = Application.VLookup(FilterRange.Value, Range("CAList"), 2, False)
Each value in the filter range is the name of an employee. What I'm actually trying to do is have the macro take the first letter of the first name, capitalize it, and then combine it with the last name. For example:
Alfred E. Neuman = ANeuman
The trick is some employees use a middle initial and some don't. I think the easiest way to do that is through VLOOKUP so I can change the table as employees come / go. Perhaps is might be easier to simply have the code do just do that from the value that is in the filtered field rather than execute a VLOOKUP? Just a thought.
------------------------------------------------------------
Option Explicit
'Generates an inputbox to select column containing desired extraction criteria'
'and creates separate tab with headings for each unique criteria found.
'Assumes headings are in row 1 of master data sheet.'
Sub FilterData()
Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
Dim Datarng As Range, FilterRange As Range, objRange As Range, CAList As Range
Dim rowcount As Long
Dim colcount As Integer, FilterCol As Integer
Dim SheetName As String
Dim wkSt As String
Dim CAName As String
Dim CAName2 As Single
Dim wkBk As Worksheet
'master sheet
Set ws1Master = ActiveSheet
'set the Column you are filtering'
top:
On Error Resume Next
Set objRange = Application.InputBox("Select One Column Only To Filter", "Range Input", , , , , , 8)
On Error GoTo 0
If objRange Is Nothing Then
Exit Sub
ElseIf objRange.Columns.Count > 1 Then
GoTo top
End If
FilterCol = objRange.Column
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error GoTo progend
'add filter sheet
Set wsFilter = Sheets.Add
With ws1Master
.Activate
.Unprotect Password:="" 'add password if needed
rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
colcount = .Cells(1, .Columns.Count).End(xlToLeft).Column
If FilterCol > colcount Then
Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
End If
Set Datarng = .Range(.Cells(1, 1), .Cells(rowcount, colcount))
'extract Unique values from FilterCol
.Range(.Cells(1, FilterCol), _
.Cells(rowcount, _
FilterCol)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wsFilter.Range("A1"), _
Unique:=True
rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
If Len(FilterRange.Value) > 0 Then
'add the FilterRange to criteria
wsFilter.Range("B2").Value = FilterRange.Value
SheetName = RTrim(Left(FilterRange.Value, 31))
'if FilterRange sheet exists
'update it
If SheetExists(SheetName) Then
Sheets(SheetName).Cells.Clear
Else
'add new sheet
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = SheetName
End If
Datarng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=Sheets(SheetName).Range("A1"), _
Unique:=False
'Freezes the top row
Application.ScreenUpdating = True
Cells(2, 1).Select
ActiveWindow.FreezePanes = True
'formats the data
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
Rows("1:1").Select
With Selection.Font
.Size = 11
Cells.Select
ActiveWindow.Zoom = 90
End With
'Applies data filters
With ActiveSheet
.AutoFilterMode = False
.Range("A1:W1").AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End With
End If
Next
.Select
End With
progend:
wsFilter.Delete
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err > 0 Then
MsgBox (Error(Err)), vbCritical, "Error"
Err.Clear
End If
'Autofits all columns in new tabs
'Application.ScreenUpdating = False
'wkSt = ActiveSheet.Name
'For Each wkBk In ActiveWorkbook.Worksheets
'On Error Resume Next
'wkBk.Activate
'Cells.EntireColumn.AutoFit
'Next wkBk
Sheets(wkSt).Select
Application.ScreenUpdating = True
End Sub
------------------------------------------------------------
I continue to be appreciative of the expertise of the forum members and their consideration in helping and educating others. Many thanks in advance.