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/show...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 = ThisWS

you 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/bfbu8w5s70...e%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.

1. 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.
2. Yes, create a new worksheet for each manager.
3. Yes, filter the staff data, columns B:N on the "Unique Resources" sheet and then,
4. Where there is a staff name in column B, copy this and only the 'non blank' cells to the respective "Managers" sheet, then,
5. 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'.
6. 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