CODEWITHSUNDEEP
vbaexcel
CCP
CCP

Reputation: 129

Excel worksheet.name with two cell value criteria

My issue today is trying to get a new worksheet name to have two different cell.values when being named.

The current code takes the data from one tab and creates different worksheets based on what is in cell range K7. So each tab is populated with the data based on the K7 column. Currently I have the new worksheet names set at 

wsnew.name = "NIIN " + cell.value

Which does its job and brings back tabs labeled "NIIN xxxxxxxx" .

I also have another column titled 'Sample' with range starting at A7.

The values for this column are all the same if it has the same K7 values.

Is there a way to get VBA to find the cell value from both A7 and K7 and add it the worksheet name?

Ideally I would like it to be something like this 

wsnew.name = "Sample " + cell.value (a7 range) + " NIIN " + cell.value (k7 range)

Adding the code provided gives me worksheet names such as "Sample xxxxxx NIIN "

The xxxxx should actually be infront of the NIIN so that it reads "Sample..... NIIN xxxxxx" 

WSNew.Name = "Sample " & cell.Offset(0, 10).Value  & " NIIN " &  cell.Value

This is the code i added and it switched the format to "Sample NIIN xxxxxx"

Which works well however i am still not getting the value after Sample.

I have tried the cell.offset (O,-10).value however that gives me an error

The code below is what comes before the worksheet naming 

Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                  Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            CCount = 0
            On Error Resume Next
            CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
            On Error GoTo 0

            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"

Original sheet with the data and micro

What the code does when cell.value comes after & " NIIN "

I hope these pictures help with the question.

As you can see from the pictures when the macro is clicked, it creates many sheets based on the criteria in K7 which is the NIIN field.

As you can also see the value under EY Sample is what i want in the output after "Sample..."

So that it reads (for example) "Sample 5 NIIN 1212"

This is the entire code. I am sure there is a much better way to have written it out. I used the basic knowledge and experience that i have. Many apologies for the headache this is creating 

Sub Copy_To_Worksheets()
Dim CalcMode As Long
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum As Long
Dim My_Table As ListObject
Dim ErrNum As Long
Dim ActiveCellInTable As Boolean
Dim CCount As Long

'Select a cell in the column that you want to filter in the List or Table

Application.GoTo Sheets("SplitInWorksheets").Range("K7")

If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro is not working when the workbook or worksheet is protected", _
           vbOKOnly, "Copy to new worksheet"
    Exit Sub
End If

Set rng = ActiveCell

'Test if rng is in a a list or Table
On Error Resume Next
ActiveCellInTable = (rng.ListObject.Name <> "")
On Error GoTo 0

'If the cell is in a List or Table run the code
If ActiveCellInTable = True Then

    Set My_Table = rng.ListObject
    FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1

    'Show all data in the Table/List
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    ' Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True




  'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                  Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            CCount = 0
            On Error Resume Next
            CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
            On Error GoTo 0

            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
            Else
                Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.Name = "Sample " & cell.Offset(0, 10).Value & " NIIN " & cell.Value

                If Err.Number > 0 Then
                    ErrNum = ErrNum + 1
                    WSNew.Name = "Error_" & Format(ErrNum, "0000")
                    Err.Clear
                End If
                On Error GoTo 0

                'Copy the visible data and use PasteSpecial to paste to the new worksheet
                My_Table.Range.SpecialCells(xlCellTypeVisible).Copy
                With WSNew.Range("A1")
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                    .Select
                End With
            End If

            'Show all data in the Table/List
            My_Table.Range.AutoFilter Field:=FieldNum

        Next cell

       'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0



    End With

    If ErrNum > 0 Then MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" & vbNewLine & _
       "There are characters in the Unique name that are not allowed in a sheet name or the sheet exist."

    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With
Else
    MsgBox "Select a cell in the column of the List or Table that you want to  filter"
End If

End Sub

Upvotes: 1

Views: 1650

Answers (1)

Marcucciboy2
Marcucciboy2

Reputation: 3261

In VBA you concatenate strings with the & character. Second, to access column K when you're looping through column A, you can just do a simple .Offset(row,col).

So your line of code becomes:

WSNew.Name = "Sample " & cell.Value & " NIIN " & cell.Offset(0,10).Value
'SheetName =  Sample   +     A7     +   NIIN   +          K7

Upvotes: 2

Related Questions