G
Guest
Working with a macro I found at http://www.contextures.com/excelfiles.html
and I am stumped. To be honest, I am not strong with VBA, just walking
through it logically isn't getting it, and I am hoping the guru's on this
board can help me wake up and see the problem. )
Two issues:
1. (See code at the end of this message). My raw data sheet contains 1900
rows, and A to Y columns. The sheets create and the data is distributed
properly but something strange is happening... the values in columns A
through N are transfering just fine, but columns O through Y are not. I
tried another approach based on this macro
http://www.rondebruin.nl/copy5.htm#all and oddly enough the same columns of
data had the same problem.
Sample Data:
A B C
LastName, FirstName Title Department.....
The worksheets created sort the employees by department. Cells A, B, C, L,
O, R, U & X are text and all others are $.
2. How can I get the macro below to perform AutoFit on all the worksheets
it creates?
Thanks so much for your help as always.
Scott
Macro I am using now:
Sub FilterCities()
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
'include bottom most header row
Const TopLeftCellOfDataBase As String = "A1"
'what column has your key values
Const KeyColumn As String = "C"
'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
rsp = 6
Set TempWks = Worksheets.Add
With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With
'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True
'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With
With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With
'check for individual Team worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If
'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)
'transfer data to individual Team worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
and I am stumped. To be honest, I am not strong with VBA, just walking
through it logically isn't getting it, and I am hoping the guru's on this
board can help me wake up and see the problem. )
Two issues:
1. (See code at the end of this message). My raw data sheet contains 1900
rows, and A to Y columns. The sheets create and the data is distributed
properly but something strange is happening... the values in columns A
through N are transfering just fine, but columns O through Y are not. I
tried another approach based on this macro
http://www.rondebruin.nl/copy5.htm#all and oddly enough the same columns of
data had the same problem.
Sample Data:
A B C
LastName, FirstName Title Department.....
The worksheets created sort the employees by department. Cells A, B, C, L,
O, R, U & X are text and all others are $.
2. How can I get the macro below to perform AutoFit on all the worksheets
it creates?
Thanks so much for your help as always.
Scott
Macro I am using now:
Sub FilterCities()
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
'include bottom most header row
Const TopLeftCellOfDataBase As String = "A1"
'what column has your key values
Const KeyColumn As String = "C"
'where's your data
Set DataBaseWks = Worksheets("AAA Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
rsp = 6
Set TempWks = Worksheets.Add
With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With
'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True
'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With
With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With
'check for individual Team worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If
'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value &
Chr(34)
'transfer data to individual Team worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D12"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function