VBA Create Sheets and Add Formula To Each Cell In Range

[hobbiton73]

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.

[Bob Phillips]

See if this works


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
Dim savedValue As Variant

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

With Range("C5:N" & LastRow)

savedValue = Range("A1").Value
Range("A1").Value = -1
Range("A1").Copy
.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply
Range("A1").Value = 100
Range("A1").Copy
.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
Range("A1").Value = savedValue
End With
End If

Columns("B:N").AutoFit
Next cell
End Sub

[hobbiton73]

Hi @xld, thank you so very much for taking the time to reply to my post. The solution works perfectly.

All the best and kind regards

[hobbiton73]

Hi @xld, I hope you are well.

I'm very sorry to trouble you, but I wonder whether you may be able to help me please.

You kindly helped me by putting the above solution together for me which works great, but I'm looking to make some changes and I'm just not too sure how to do this.

What I'd like to do if at all possible is:



Only perform the calculation here:



If LastRow >= StartRow Then


With Range("C5:N" & LastRow)
savedValue = Range("A1").Value
Range("A1").Value = -1
Range("A1").Copy
.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply
Range("A1").Value = 1
Range("A1").Copy
.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
Range("A1").Value = savedValue
.NumberFormat = "0%"
End With

If the source cell is blank, then



If the result in the cells for each of the 'Destination' sheets is 100% change the value of the cell to "NSR".


I'm pretty sure this is an 'If' statement, but I'm just not too sure of where this would need to go.

I just wondered whether you may be able to offer some guidance please on how I may go about changing this.

Many thanks and kind regards

Chris