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:
