hobbiton73
01-20-2014, 02:22 AM
Hi, I wonder whether someone may be able to help me please.
I'm using the code below to perform the following:
Search column O of my data sheet for unique values.
For each value create a new sheet.
Copy pertient data from the data sheet to each newly created sheet
Sub CreateSheets()
Dim WBO As Workbook
Dim ThisWS
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer
Dim rngResults As Range 'filter range
Dim LastRow As Long
Dim Values As Range
Dim iX As Integer
Set WBO = ThisWorkbook
Set rngFilter = Range("O4", Range("O" & Rows.Count).End(xlUp))
Set rngResults = Range("A1", Range("N" & Rows.Count).End(xlUp))
Set rngformula = Range("C5", Range("N" & Rows.Count).End(xlUp))
With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("O5", Range("O" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
End With
For Each cell In rngUniques
Worksheets.Add After:=Worksheets(Worksheets.Count)
ThisWS = cell.Value
ActiveSheet.Name = ThisWS
'counter = counter + 1
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1")
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
If LastRow >= StartRow Then
With Range("B5:N" & LastRow)
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Key2:=.Cells(1, 2), order2:=xlAscending
End With
End If
Columns("B:N").AutoFit
Next cell
End Sub
The code works fine, but I'm having a great deal of difficulty with some changes that need to be made.
Each newly created sheet has a list of names in column B, then figures in columns C:N starting at row 5 for a dynamic number of rows.
What I'd like to do is apply the following formula to each cell in columns C:N: 'cell.value = 100 - Val(cell.value)' , but I don't know how to reference each newly created sheet. In addition, where the returned result is zero, I would like the cell to be blank.
I just wondered whether someone may be able to look at this please and offer some guidance on how I may go about this.
I'm using the code below to perform the following:
Search column O of my data sheet for unique values.
For each value create a new sheet.
Copy pertient data from the data sheet to each newly created sheet
Sub CreateSheets()
Dim WBO As Workbook
Dim ThisWS
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer
Dim rngResults As Range 'filter range
Dim LastRow As Long
Dim Values As Range
Dim iX As Integer
Set WBO = ThisWorkbook
Set rngFilter = Range("O4", Range("O" & Rows.Count).End(xlUp))
Set rngResults = Range("A1", Range("N" & Rows.Count).End(xlUp))
Set rngformula = Range("C5", Range("N" & Rows.Count).End(xlUp))
With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("O5", Range("O" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
End With
For Each cell In rngUniques
Worksheets.Add After:=Worksheets(Worksheets.Count)
ThisWS = cell.Value
ActiveSheet.Name = ThisWS
'counter = counter + 1
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1")
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
If LastRow >= StartRow Then
With Range("B5:N" & LastRow)
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Key2:=.Cells(1, 2), order2:=xlAscending
End With
End If
Columns("B:N").AutoFit
Next cell
End Sub
The code works fine, but I'm having a great deal of difficulty with some changes that need to be made.
Each newly created sheet has a list of names in column B, then figures in columns C:N starting at row 5 for a dynamic number of rows.
What I'd like to do is apply the following formula to each cell in columns C:N: 'cell.value = 100 - Val(cell.value)' , but I don't know how to reference each newly created sheet. In addition, where the returned result is zero, I would like the cell to be blank.
I just wondered whether someone may be able to look at this please and offer some guidance on how I may go about this.