The purpose of this is to find the column who has the header "Type Test" and loop through that column, in this case B to find all unique value cells. If the string in column B is unique and does not replace, I need it to make a copy of the worksheet whose name matches the trial name in column A. So for Test 1 who has a row index of 3 and a column index of 2, will make a copy of the worksheet in the current workbook called "DEF" and rename the copy to be "Test 1"

For example here is my data

1.  A            B
   

2.  Trial     Type_Test 
   

3.  DEF        Test 1
   

4.  ABC        Test 3
   

5.  ABC        Test 10
   

6.  DEF        Test 14 
   

7.  ABC        Test 10 
   

However, I dont want to make a copy of the sheet ABC if the column B values repeat for column A, so since rows 3 and 5 are the same, I only want to make copies of ABC sheet twice, once for row 2 and once for row 3. Row 5 can be ignored since it is the same as row 3.

I have written a code that does the first part regarding make a sheet and renaming it, I just cant get the copy the other worksheet part.

Public Sub Main()

Dim srtsht As Variant, sysnum As Variant, arr As Variant, partnum As Variant
Dim wsh As Worksheet

    srtsht = Sheets("Sheet1").Range("E2:E15")

    With CreateObject("scripting.dictionary") ' store data in array where each item is associated with a unique key
        For Each sysnum In srtsht
            arr = .Item(sysnum)
        Next sysnum
    For Each value In .Keys
        On Error Resume Next
        If value <> "" Then
            Set wsh = Nothing ' clear the variable wsh
            Set wsh = Worksheets(CStr(value)) ' try to set wsh to the sheet with Value as name
            On Error GoTo 0
            If wsh Is Nothing Then 

            Call position 
         
            If Worksheets("Sheet1").Cells(A_row,A_col).Value = "ABC" Then 
            Worksheets("ABC").Copy After:=ActiveSheet 
            wsh = Worksheets("Sheet1").Cells(A_row,A_col).Values 
            Worksheets("ABC (2)").name = wsh 
            wsh.name = CStr(Value)
            End If 
            Else 
               MsgBox "Sheet" & Values & "already exists.", vbInformation 
            End If 
          End If  
       Next Value 
     End With 
End Sub 

Sub position () 
Dim syswaivernum As Range, partnumber As Range

For Each syswaivernum In Worksheets("Sheet1").Range("A1:Z20")
        If syswaivernum.value = "Number(s)" Then
        sysnumcol = syswaivernum.Column
        sysnumrow = syswaivernum.Row
        End If
    Next syswaivernum
For Each partnumber In Worksheets("Sheet1").Range("A1:Z20")
        If partnumber.value = "Part" Then
        A_col = partnumber.Column
        A_row = partnumber.Row
    End If
Next partnumber

End Sub


            

CodePudding user response：

Try this - see comments inline:

Public Sub Main()

    Dim wb As Workbook, tst As String, wsName As String
    Dim c As Range, ws As Worksheet, dict As Object
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")
    
    Set dict = CreateObject("scripting.dictionary")
    For Each c In ws.Range("E2:E15").Cells
        tst = c.Value
        If Not dict.exists(tst) Then 'first time seeing this value?
            dict.Add tst, True '###
            If Not SheetExists(tst) Then
                wsName = c.EntireRow.Columns("A").Value    'sheet to be copied
                If SheetExists(wsName) Then 'if there's a sheet for wsName
                    wb.Worksheets(wsName).Copy After:=ws       'copy the sheet
                    wb.Worksheets(ws.Index   1).Name = tst  '### rename the copy
                End If
            Else
                MsgBox "Sheet '" & wsName & "' already exists"
            End If
        End If
    Next c
End Sub

'Does a sheet named `SheetName` exist?
'  Defaults to checking `ThisWorkbook` if `wb` is not specified
Function SheetExists(SheetName As String, _
                     Optional wb As Excel.Workbook) As Boolean
    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    SheetExists = Not wb.Sheets(SheetName) Is Nothing
End Function