VBA Create Sheets & Copy Data

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

I'm using the following code below to perform the following:


Search a given list (Column O) on my 'Source' sheet for unique records, then
When a unique value is found
Create a new worksheets using this value as the sheet name, then
Copy pertinent to data from the 'Source' sheet to each 'newly' created 'Destination 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
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))

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("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
End With
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

With Sheets("Unique Records")
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub

I initially found the source of this code on the internet, and then received some further guidance here URL="http://www.vbaexpress.com/forum/showthread.php?48719-VBA-Create-Sheets-and-Add-Formula-To-Each-Cell-In-Range"]http://www.vbaexpress.com/forum/showthread.php?48719-VBA-Create-Sheets-and-Add-Formula-To-Each-Cell-In-Range[/URL]

The code works fine, but I've come across a few issues, which sadly, I've been unable to resolve.
What I'd like to do, if at all possible please is:


Only copy the values in columns C:N from the 'Source' to the relvant 'Destination' sheet only if they are not blank, and
If the 'Cells in column C:N on the 'Destination' sheets are equal to "1" change the cell value to "NSR".


I just wondered whether someone may be able to look at this please and offer some help on how I may go about achieving this.

Many thanks and kind regards

[westconn1]

ThisWS = cell.Value
ActiveSheet.name = ThisWSyou should specify which worksheet any range is in

when working with multiple sheets, avoid working with the activesheet as much as possible



set mysht = activesheet ' or better specify the sheet by name
Set rngFilter = mysht.Range("O4", Range("O" & Rows.Count).End(xlUp))
Set rngResults = mysht.Range("A1", 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
set newsht = Worksheets.Add After:=Worksheets(Worksheets.Count)
ThisWS = cell.Value
newsht.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 newsht.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
End With
With Range("B5:N" & LastRow)
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Key2:=.Cells(1, 2), order2:=xlAscending
End With
End If
newsht.Columns("B:N").AutoFit
Next cell apply the correct sheet object to all ranges, if i can not guess to which sheet the range should apply, how do you expect excel to?
i may have specified the wrong sheet in some cases


If the 'Cells in column C:N on the 'Destination' sheets are equal to "1" change the cell value to "NSR".
use find replace on the range?

Only copy the values in columns C:N from the 'Source' to the relvant 'Destination' sheet only if they are not blank
it may possibly be easier to remove blanks after copying

[hobbiton73]

Hi @westconn1, thank you for taking the time to reply to my post.

I'm just trying to add the code which you kindly provided into my script and there appears to be a syntax error on this line:

Set newsht = Worksheets.Add After:=Worksheets(Worksheets.Count)

I just wondered whether you could possibly have look at this pleas.

Many thanks and kind regards

[westconn1]

sorry, my error
when you use =, arguments should be enclosed in brackets ()

Set newsht = Worksheets.Add(After:=Worksheets(Worksheets.Count))

[hobbiton73]

Hi @westconn1, thank you very much for coming back to me with this, it is greatly appreciated.

I've re-inout the code you ikindly provided, but when I run this, I receive the following error: 'Run time error '91': object variable or block variable not set'.

I've been into Debug and the line where the error is occurring is:
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1").

Many thanks and kind regards

[westconn1]

i would guess that rngresults failed, try

Set rngResults = mysht.Range("A1", mysht.Range("N" & mysht.Rows.Count).End(xlUp))

'or

with mysht
Set rngResults = .Range("A1", .Range("N" & .Rows.Count).End(xlUp))
end with

[hobbiton73]

Hi @westconn1, thank you very much for taking the time to come back time with this.

I've amended the script with the line you kindly sent, and although the code does run without error, instead of the correct data being copied and paste into each 'Destination' sheet, each cell is filled with the value of 1.

Many thanks and kind regards

[mancubus]

can you post your workbook with fake data?

[hobbiton73]

Hi @mancubus, thank you for taking the time to reply to my post.

The file is rather large, so I've been unable to attach the file, but please find a link to the file here: https://www.dropbox.com/s/bfbu8w5s704f8kk/Managers%20List%20Extract%20-%20Home%20260114.xls

When you open the file, there will be four sheets, "Macros", "All Data", "Flexible Resources List", and "Unique Records".



Please ignore "all Data" and the "Flexible Resources List" sheets.
The "Macros" sheet contains the button to run the macro, and
The "Unique Records" sheet contains the data which is used to create the new sheets using the aforementioned macro.


Please note that I am also experiencing an intermittent fault when running the macro: When I initially run the macro I receive a 'Run time error '1004' We couldn't do this for the selected range of cells. Select a single cell within a range of data and then try again. Debug highlights this line as the cause:
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True but I'm not sure why.

To get around this I apply a filter then remove it manually, go into to debug and run the script from there.

I hope this makes sense.

Once again many thanks and kind regards

[mancubus]

hi hobbiton73.
you are welcome.

i'd like to repeat the steps to see if a understood your requirement correctly.

1. create a unique list of line managers.
2. create a new worksheet for each line manager in the list.
3. filter the table for each line manager to get their staff data.
4. copy the filtered rows to worksheet with their names.
5. multiply the staff's month values by -1
6. add 1 to multiplied results.
7. if the results are equal to 1, replace them with "NSR".

if the points above are correct i have a question. what do you mean by "Only copy the values in columns C:N from the 'Source' to the relevant 'Destination' sheet only if they are not blank"?
does that mean all cells in B:N must be non-blank cells? or one non-blank cell is enough to call that row as non-blank?

if second case is true, will blank cells be treated as 0 values or will they be ignored when doing multiplication and addition operations?


another question: what is StartRow? it's not declared. it's not assigned a value either. is it 1?

[hobbiton73]

Hi @mancubus, thank you very much for coming back to me so quickly with this.

I'll try to answer your points one by one.



Yes, create a unique list of managers names from the values in column O on the sheet "Unique Records" with the headers starting at row 4, with data running from row 5 with a dynamic number of rows.
Yes, create a new worksheet for each manager.
Yes, filter the staff data, columns B:N on the "Unique Resources" sheet and then,
Where there is a staff name in column B, copy this and only the 'non blank' cells to the respective "Managers" sheet, then,
The formula for each cell in columns C:N on each of the managers sheet, starting at row 5 for a dynamic number of rows is: 'The Value "1" minus the cell value'.
If the results in the cells is zero, change this to "NSR".


My apologies the code should have the following line below the 'Set rngResults':
Const StartRow As Long = 5

I hope this helps.

Kind Regards

[mancubus]

hi again.

- you want to copy blank column A and 3 blank rows above the table from Unique Records to new sheets as well?

- change resultant 0s to "NSR", rather than 1s in the first post?



maybe i dont understand. or we think differently for blanks vs non blanks.
Staff Alison M on row 11 will not be copied. because cells C11, D11, E11, F11 are blank. ????
if they are copied (blank = 0), 1-(cell value) is 1 and blank cell is replaced with value 1?

or you mean there are blank cells in column B even a LM name appears in column O?

what is it? :)

[hobbiton73]

Hi @mancucbus, thank you for coming back to me with this, and my apologies for not being clear.



Yes please, I'd like all the 'Manager sheets to replicate the formatting of "Unique Records" sheet.
My apologies, yes please change the resulting zeros to "NSR"
In respect of the blanks, using the example you have provided, I would like to copy the value in column B, and only those values in columns G:N. In essence. If the cell is blank, do not copy that cell and move onto the next in the row.


Many thanks and kind regards

[mancubus]

ok. maybe, to me, wording it like "i dont want blank cells be processed" would be better. sorry for my poor English. :)

try this with a copy of your file.



Sub CreateSheets_CopyData()

Dim cll As Range
Dim rngResults As Range 'filter range
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim LMngr As String
Dim UqLM
Dim LastRow As Long, calc As Long, i As Long
Const StartRow As Long = 5

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
calc = .Calculation
.Calculation = xlCalculationManual
End With

With Worksheets("Unique Records")
If .AutoFilterMode Then .AutoFilterMode = False
LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Set rngResults = .Range("A1:N" & LastRow)
Set rngFilter = .Range("O4:O" & LastRow)
For Each cll In rngFilter.Offset(1).Resize(rngFilter.Rows.Count - 1)
If InStr(LMngr, cll.Value) = 0 Then LMngr = LMngr & "|" & cll.Value
Next cll
UqLM = Application.Transpose(Split(Mid(LMngr, 2), "|"))
End With

For i = LBound(UqLM) To UBound(UqLM)
rngFilter.AutoFilter Field:=1, Criteria1:=UqLM(i, 1)
Worksheets.Add After:=Worksheets(Worksheets.Count)
With ActiveSheet
.Name = UqLM(i, 1)
rngResults.SpecialCells(xlCellTypeVisible).Copy
With .Range("A1")
.PasteSpecial
.Select
End With
.Columns.AutoFit
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
If LastRow >= StartRow Then
With .Range("C5:N" & LastRow)
For Each cll In .SpecialCells(xlCellTypeConstants, 1)
cll.Value = 1 - cll.Value
If cll.Value = 0 Then cll.Value = "NSR"
Next cll
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Key2:=.Cells(1, 2), Order2:=xlAscending
End With
End If
End With
rngFilter.Parent.AutoFilterMode = False
Next i

Worksheets("Unique Records").Select

With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationManual
End With

End Sub

[hobbiton73]

Hi @mancubus, you have absolutely no need to apologise, your help is truly appreciated.

I've tested the script you've kindly taken the time to put together and it works perfectly, thank you so much!

May I ask, would it be at all possible please for you to insert some comments into the code, so I can learn from this.

Many thanks and kind regards

[mancubus]

you're welcome. i am glad it helped.

sure. i will try to explain here. and amend the code to include comments.

will do it whenever i have time.


cheers.

[mancubus]

it's weird. the total of 1 - cell value subractions is OK. but writes the results to wrong cells.
only first row is true. maybe because of specialcells method.
will work on it.

[hobbiton73]

Hi @mancucus, thank you for coming back to me with this and for highlighting the issue re. the pasting of data to the wrong cells.

I hadn't done a full check at the time of making my previus post.

Yes if you could work on this, and I'll aslo spend some time looking into this.

Many thanks and kind regards

[mancubus]

you are welcome.there is no problem with copy-paste. when i run the code's copy-paste bit only, it's OK. ----- and no problem with (1 - cell value) calculations or 0s-to-NSR change or the order of month values. ----- the only problem is calculated and replaced values are written to wrong staff's row. ----- i dont know why. :)

[hobbiton73]

Hi @mancubus, I hope you are well.

As promised, I've continued to to work on this and I've come up with a solution.

I've changed this section of code:


LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
If LastRow >= StartRow Then
With .Range("C5:N" & LastRow)
For Each cll In .SpecialCells(xlCellTypeConstants, 1)
cll.Value = 1 - cll.Value
If cll.Value = 0 Then cll.Value = "NSR"
Next cll
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Key2:=.Cells(1, 2), Order2:=xlAscending
End With
End If


to


LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
If LastRow >= StartRow Then
For Each cll In .Range("C5:N" & LastRow)
cll.Value = 1 - cll.Value
If cll.Value = 1 Then
cll.Value = "NSR"
End If
If cll.Value = 0 Then
cll.Value = ""
End If
Next cll
End If

I appreciate that this may not be the most elegant, or perhaps, even the correct way to write this. Perhaps there is a better way?

As before, if you could add some comments to the code that woudl be really good.

Once again, sincere thanks for all your help.

Kind regards

[mancubus]

.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Key2:=.Cells(1, 2), Order2:=xlAscending

[mancubus]

the problem arises from sorting. im sorry for discovering late as it is obvious. i feel stupid sometimes. :) it sorts C-N without staff names.

[hobbiton73]

Hi @mancubus, you're certainly not stupid!

I too looked at the sorting and found that in reality I didn't need to perform this task on the results page, so I have removed this

I look forward to receiving your code comments.

All the best and kind regards

[mancubus]

Sub CreateSheets_CopyData_Commented()

'http://www.vbaexpress.com/forum/showthread.php?48753-VBA-Create-Sheets-amp-Copy-Data

Dim cll As Range, rngResults As Range, rngFilter As Range
Dim LMngr As String, UqLM
Dim LastRow As Long, calc As Long, i As Long
Const StartRow As Long = 5

With Application
.DisplayAlerts = False 'suppress warning messages
.ScreenUpdating = False 'stop screen flickering
.EnableEvents = False 'prevent event codes from firing when code is running.
calc = .Calculation 'assign current calculation mode to calc variable
.Calculation = xlCalculationManual 'set calculation mode to manual calculation
End With

With Worksheets("Unique Records")
If .AutoFilterMode Then .AutoFilterMode = False 'remove filters, if any
LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
'find the first non blank cell from backward (xlPrevious), assign its row number to LastRow variable
Set rngResults = .Range("A1:N" & LastRow) 'range to copy from
Set rngFilter = .Range("O4:O" & LastRow)
'range to create conditions copying will be based. include header to ease filtering
'create an array of unique values from column O
For Each cll In rngFilter.Offset(1).Resize(rngFilter.Rows.Count - 1)
'for unique values, exclude header by ofsetting the range by 1 row. then dowsize the range by 1 tow for this offset.
If InStr(LMngr, cll.Value) = 0 Then LMngr = LMngr & "|" & cll.Value
Next cll
'loop thru all cells in rngFilter, concatenate all Line Managers' names, adding a | char between names, on condition that, each name is repeated once.
'InStr returns the position (from left to right) of a substring in a string. if the result is 0 it means the substring is not present in the string
'so concatenate it to LMngr variable. if it returns a value greater than 0, it means the substring is present in the string. donot cancatenate that name.
'so after 3 loops LMngr is ""John|Ray Mc|Liz Je. the first character is "". so remove it using MID function.
'finally create an array from LMngr using SPLIT function with | as delimeter
UqLM = Split(Mid(LMngr, 2), "|")
End With

For i = LBound(UqLM) To UBound(UqLM)
'loop thru array elements from first to last index
rngFilter.AutoFilter Field:=1, Criteria1:=UqLM(i)
'filter range for each array element
Worksheets.Add After:=Worksheets(Worksheets.Count)
'add a new worksheet after existing worksheets. Worksheets.Count gives the number total worksheets = last worksheet index
With ActiveSheet
.Name = UqLM(i) 'rename it with array element
rngResults.SpecialCells(xlCellTypeVisible).Copy 'copy the visible rows of columns A-N
With .Range("A1")
.PasteSpecial 'paste all
.Select 'to remove the selection after copying
End With
.Columns.AutoFit
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
If LastRow >= StartRow Then
With .Range("C5:N" & LastRow)
For Each cll In .SpecialCells(xlCellTypeConstants, 1) 'limit above range to cells with numbers only
cll.Value = 1 - cll.Value 'new cell value = 1 - current cell value
If cll.Value = 0 Then cll.Value = "NSR" 'replace 0s with NSR
Next cll
.Offset(, -1).Resize(, .Columns.Count + 1).Sort Key1:=.Cells(1, 1).Offset(, -1), Order1:=xlAscending, Header:=xlNo
'offset whole range by 1 column to left. resize it +1 column to include the last column lost after offset
'offset Key1 cell by one column to left because of the above offsetting.
'sort the new range on staff names, ascending, no headers.
End With
End If
End With
rngFilter.Parent.AutoFilterMode = False 'remove filter from worksheet. rngFilter is a range. its parent is worksheet.
Next i
Worksheets("Unique Records").Select
'restore before macro settings
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationManual
End With
End Sub

[mancubus]

i hope it helps. do a find-replace all to change *'s to spaces. but keep one * which is in LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row line. i cant paste linebreaks etc when posting form my office pc in vbax. therefore i emailed the code to my personel email account. and paste it here via my mobile. sorry for the invonvenience.

[hobbiton73]

Hi @mancubus, that's absolutely no problem at all. Sincere thanks for putting this together.

All the best and kind regards

[mancubus]

you are welcome. ----- i changed the unique list bit slightly. it was a copy-paste from another project. :whistle: ---- that's one of the common methods used to create a unique list. we dont write array elements to cells. so why bother transposing the array to suit dimensions? just use it to get the list. ----- once an array is created, you can sort its elements. just google "excel vba sort array elements".

[hobbiton73]

Hi, that's great. Thank you.