使用单元格值作为工作表名称

Question

I want to paste data from a Workbook to another workbook into a sheet which has the name of a cell value. I don't know if that's possible, but I'm struggling with that and I can't find anything similar on internet.

This is my code so far:

'This creates a sheet from a range and gives it the name of the cell so it can be from 5 to 10 sheets'

For Each Cell In Range("G5:G15")
    If Cell.Value <> "" Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = Cell.Value
    End If
Next

After other code which is not important, I made this:

Dim AutoFilterRng As Range
Dim WorksheetName As String

For Each Cell In Range("H5", Range("H5").End(xlDown))
    If Cell.Value <> "" Then
        WorksheetName = Cell.Offset(0, -1).Value    
        Workbooks.Open MJFile                    'Opens the file where data I want to copy
        ActiveSheet.Range("A:U").AutoFilter Field:=12, Criteria1:="*" & Cell.Value    'Filters depending on the cell value
        With ActiveSheet.AutoFilter.Range
            Set AutoFilterRng = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        End With
        ActiveSheet.AutoFilter.Range.Offset(1, 0).Resize(ActiveSheet.AutoFilter.Range.Count - 1).Copy
        Workbooks.Open WBOR    'Opens the Workbook where I want to paste data
        Worksheets(WorksheetName).Range("A1").Paste    'This gives an  error and it is where I would like to paste my data
        Workbooks.Open MJFile
        AutoFilterMode = False
    End If
Next

Thank you very much in advance

If you want to see the whole code:

Sub AddTO()
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
'------------------------------------------------------------------------------------------------------------------------------------------------------'

'Open TO FIle'

Dim WBOR As String
Dim MJFile As String
Dim TOFile As String
Dim Path As String

WBOR = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name

'On Error GoTo Fin
MsgBox "Choose Bear File"
With Application.FileDialog(msoFileDialogFilePicker)
    .Filters.Clear
    .AllowMultiSelect = False
    If .Show = -1 Then
        TOFile = .SelectedItems(1)
    End If
End With

Workbooks.Open TOFile

'Filter Bear File to Only Necessary TO'
Dim NameRng As Range
Dim TORng As Range
Dim DeliveryWeek As String
Dim i As Long

Workbooks.Open WBOR
Set NameRng = Worksheets("Tasks_Orders_Info").Range("E5", Range("E5").End(xlDown))
Workbooks.Open TOFile
Set TORng = Worksheets("WS Lead Plan1").Range("G2", Range("G2").End(xlDown))
Workbooks.Open WBOR
DeliveryWeek = "*Week_" & Worksheets("Tasks_Orders_Info").Range("C5").Value & "*"

Workbooks.Open TOFile
For i = TORng.Count To 1 Step -1
    Select Case True
        Case TORng.Cells(i) Like DeliveryWeek
        Case Else
            TORng.Cells(i).EntireRow.Delete
    End Select
Next i

'Add TO to MJ File'
Workbooks.Open WBOR
TORng.Copy
Worksheets("Tasks_Orders_Info").Range("G5").PasteSpecial xlPasteValues
Worksheets("Tasks_Orders_Info").Range("G5").End(xlDown).PasteSpecial xlPasteValues

Workbooks.Open TOFile
ActiveWorkbook.Close SaveChanges:=False

Range("H5:H15") = "=IF(ISERR(FIND("" "",Table2[@Coder])),"""",LEFT(Table2[@Coder],FIND("" "",Table2[@Coder])-1))"
Range("I5:I15") = "=MID(Table2[@Coder],SEARCH("" "",Table2[@Coder],1)+1,SEARCH("" "", Table2[@Coder],SEARCH("" "",Table2[@Coder],1)+1)-SEARCH("" "",Table2[@Coder],1))"
Range("J5:J15") = "=IFERROR(MID(Table2[@Coder],FIND("" "",Table2[@Coder],FIND("" "",Table2[@Coder])+1)+1,FIND("" "",Table2[@Coder],FIND("" "",Table2[@Coder],FIND("" "",Table2[@Coder])+1)+1)-FIND("" "",Table2[@Coder],FIND("" "",Table2[@Coder])+1)-1),"""")"

Form1 = "=IF(OR(ISNUMBER(FIND(H5,G5,1)),ISNUMBER(FIND(I5,G5,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G5,1)))),LEFT(G5,FIND(""  "",G5,1)-3),IF(OR(ISNUMBER(FIND(H5,G6,1)),ISNUMBER(FIND(I5,G6,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G6,1)))),LEFT(G6,FIND(""  "",G6,1)-3),IF(OR(ISNUMBER(FIND(H5,G7,1)),ISNUMBER(FIND(I5,G7,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G7,1)))),LEFT(G7,FIND(""  "",G7,1)-3),IF(OR(ISNUMBER(FIND(H5,G8,1)),ISNUMBER(FIND(I5,G8,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G8,1)))),LEFT(G8,FIND(""  "",G8,1)-3),IF(OR("
Form2 = "ISNUMBER(FIND(H5,G9,1)),ISNUMBER(FIND(I5,G9,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G9,1)))),LEFT(G9,FIND(""  "",G9,1)-3),IF(OR(ISNUMBER(FIND(H5,G10,1)),ISNUMBER(FIND(I5,G10,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G10,1)))),LEFT(G10,FIND(""  "",G10,1)-3),IF(OR(ISNUMBER(FIND(H5,G11,1)),ISNUMBER(FIND(I5,G11,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G11,1)))),LEFT(G11,FIND(""  "",G11,1)-3),IF(OR(ISNUMBER(FIND(H5,G12,1)),ISNUMBER(FIND(I5,G12,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G12,1)))),LEFT(G12,FIND(""  "",G12,1)-3),IF("
Form3 = "OR(ISNUMBER(FIND(H5,G13,1)),ISNUMBER(FIND(I5,G13,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G13,1)))),LEFT(G13,FIND(""  "",G13,1)-3),IF(OR(ISNUMBER(FIND(H5,G14,1)),ISNUMBER(FIND(I5,G14,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G14,1)))),LEFT(G14,FIND(""  "",G14,1)-3),IF(OR(ISNUMBER(FIND(H5,G15,1)),ISNUMBER(FIND(I5,G15,1)),IF(J5="""",FALSE,ISNUMBER(FIND(J5,G15,1)))),LEFT(G15,FIND(""  "",G15,1)-3),""NOT FOUND"")))))))))))"
Range("B5", Range("B5").End(xlDown)) = Form1 + Form2 + Form3

Range("B5", Range("B5").End(xlDown)).Copy
Range("B5", Range("B5").End(xlDown)).PasteSpecial xlPasteValues
Range("G5", Range("G5").End(xlDown)).ClearContents

'Create New Sheets"
Range("G5:G15") = "=IFERROR(CONCAT(RIGHT(Table2[@[TASK ORDER]],LEN(Table2[@[TASK ORDER]])-SEARCH("" TO"",Table2[@[TASK ORDER]],1)),""_"",H5),"""")"
Range("G5:G15").Copy
Range("G5:G15").PasteSpecial xlPasteValues

Range("H5", Range("H5").End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Delete

For Each Cell In Range("G5:G15")
    If Cell.Value <> "" Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = Cell.Value
    End If
Next

Worksheets("Tasks_Orders_Info").Activate

'Open MJ File'
MsgBox "Choose mj extraction"
With Application.FileDialog(msoFileDialogFilePicker)
    .Filters.Clear
    .AllowMultiSelect = False
    If .Show = -1 Then
        MJFile = .SelectedItems(1)
    End If
End With

Workbooks.Open MJFile

'Delete non Users'
Dim mapjobdata As Range
Dim WorkUserRg As Range

Worksheets("map_jobs_-_feedback_and_observa").Range("A1").Select
Worksheets("map_jobs_-_feedback_and_observa").Range(Selection, Selection.End(xlDown)).Select
Worksheets("map_jobs_-_feedback_and_observa").Range(Selection, Selection.End(xlToRight)).Select

Set mapjobdata = Worksheets("map_jobs_-_feedback_and_observa").Range(Selection.Address)
Set WorkUserRg = mapjobdata.Find("Worked on by User", , xlValues, xlWhole, , , True).Offset(1, 0)
Set WorkUserRg = Worksheets("map_jobs_-_feedback_and_observa").Range(WorkUserRg, WorkUserRg.End(xlDown))

For i = WorkUserRg.Count To 1 Step -1
    If WorkUserRg.Cells(i) Like "*@email.com*" Then
        Else
            WorkUserRg.Cells(i).EntireRow.Delete
    End If
Next i

'Add MapJobs to each Sheet'
Workbooks.Open WBOR
Range("H5:H15") = "=IFERROR(RIGHT(Table2[@Coder],FIND("")"",Table2[@Coder],1)-(FIND("" ("",Table2[@Coder],1))),"""")"
Range("H5", Range("H5").End(xlDown)).Copy
Range("H5", Range("H5").End(xlDown)).PasteSpecial xlPasteValues

Dim AutoFilterRng As Range
Dim WorksheetName As String

For Each Cell In Range("H5", Range("H5").End(xlDown))
    If Cell.Value <> "" Then
        WorksheetName = Cell.Offset(0, -1).Value
        Workbooks.Open MJFile
        ActiveSheet.Range("A:U").AutoFilter Field:=12, Criteria1:="*" & Cell.Value
        With ActiveSheet.AutoFilter.Range
            Set AutoFilterRng = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        End With
        ActiveSheet.AutoFilter.Range.Offset(1, 0).Resize(ActiveSheet.AutoFilter.Range.Count - 1).Copy
        Workbooks.Open WBOR
        Worksheets(WorksheetName).Range("A1").Paste
        Workbooks.Open MJFile
        AutoFilterMode = False
    End If
Next

'------------------------------------------------------------------------------------------------------------------------------------------------------'
Fin:
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

This is the error I get and debug shows the next line:

Answer 1

This is not the answer BUT may help you:

Sub test()

    Dim shtName As String

    With ThisWorkbook

        'Let assume that the sheet name we want appears in Sheet3, range A1
        'Get sheet name
        shtName = .Worksheets("Sheet3").Range("A1").Value
        'Activate sheet with name shtName
        .Worksheets(shtName).Activate

    End With

End Sub

Answer 2

This is an untested code. I do not have the necessary data to test it. It must give you some hints in order to understand what is to be done:

Please add Option Explicit on top of your module. This will oblige you to declare all variables...

Sub sheetsAddAndCopy()
Dim WBOR As Workbook, Wmjf As Workbook, shW As Worksheet, shMJ As Worksheet
Dim AutoFilterRng As Range, WorksheetName As String, cell As Range

Const MJFile As String = "your workbook full path"
Set WBOR = ThisWorkbook
Set Wmjf = Workbooks.Open(MJFile) 'Opens the file where data I want to copy

For Each cell In WBOR.Range("H5", Range("H5").End(xlDown))
    If cell.Value <> "" Then
        WorksheetName = cell.Offset(0, -1).Value
        Set shW = WBOR.Sheets.Add(After:=Sheets(Sheets.count))
           shW.Name = WorksheetName
           Set shMJ = Wmjf.ActiveSheet
           shMJ.Range("A:U").AutoFilter field:=12, Criteria1:="*" & cell.Value    'Filters depending on the cell value
            Set AutoFilterRng = shMJ.AutoFilter.Range.Offset(1, 0).Resize(.Rows.count - 1, 1).SpecialCells(xlCellTypeVisible)
            shMJ.AutoFilter.Range.Offset(1, 0).Resize(shMJ.AutoFilter.Range.count - 1).Copy shW.Range("A1")
          shMJ.AutoFilterMode = False
    End If
Next

Answer 3

I should not use .paste instead it should be .PasteSpecial and set the Worksheet. In this case WorksheetName = Cell.Offset(0,-1).Value and then set the Worksheet with that name so it will be Dim CurrentWSName, Set CurrentWSName = ActiveWorkbook.Sheets(WorksheetName) Code will be like this:

Dim AutoFilterRng As Range
Dim WorksheetName As String
Dim CurrentWSName As Worksheet

For Each Cell In Range("H5", Range("H5").End(xlDown))
    If Cell.Value <> "" Then
        WorksheetName = Cell.Offset(0, -1).Value
        Set CurrentWSName = ActiveWorkbook.Sheets(WorksheetName)
        Workbooks.Open MJFile
        ActiveSheet.Range("A:U").AutoFilter Field:=12, Criteria1:="*" & Cell.Value
        With ActiveSheet.AutoFilter.Range
            Set AutoFilterRng = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        End With
        ActiveSheet.AutoFilter.Range.Offset(1, 0).Resize(ActiveSheet.AutoFilter.Range.Count - 1).Copy
        Workbooks.Open WBOR
        CurrentWSName.Activate
        Range("A1").PasteSpecial
        Workbooks.Open MJFile
        AutoFilterMode = False
        Workbooks.Open WBOR
    End If
Next