Add New Sheets with Name from a Range

[Jsingh96]

Hi,

Looking for some help on the below code. Instead of adding just a new sheet Set (ws = y.Sheets.Add) (Sheet1, Sheet2...) I need to create the new sheet with a name from a specific range. The range is the adjacent cells/column from "E2:E33"





Sub CopyData()

Application.ScreenUpdating = False


Application.DisplayAlerts = False
Dim ws As Worksheet
Dim x As Workbook
Dim y As Workbook
Dim rngURL As Range
Dim cll As Range

Set rngURL = Worksheets("data_pull").Range("E2:E33")
On Error GoTo errHandler
For Each cll In rngURL

DoEvents

Set x = Workbooks.Open(cll.Value)
Set y = ThisWorkbook

Set ws = y.Sheets.Add
x.Sheets("data_paste").Cells.Copy
ws.Cells.PasteSpecial
ws.Cells.Copy
ws.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False

Application.CutCopyMode = False

x.Close

Next
errHandler:
If Err.Number <> 0 Then MsgBox "There was an error." & vbNewLine & "Error " & Err.Number & vbTab & Err.Description, vbOKOnly, "Error"
Application.DisplayAlerts = True
Set x = Nothing
Set y = Nothing
Set ws = Nothing
Application.ScreenUpdating = True

End Sub





Many Thanks in Advance

 

[mikerickson]

Which cell in data_pull!E2:E33 has the name of the new sheet?

 

[Jsingh96]

Which cell in data_pull!E2:E33 has the name of the new sheet?

Hi,

Each cell in the range has a different name -

 

[mikerickson]

Which one do you want for the name of the new sheet?

 

[Jsingh96]

Which one do you want for the name of the new sheet?

The code I posted loops through the range, so I want to create the new sheet based on the cell D2, and then D3, and then D4 etc.

Cheers

 

[mikerickson]

Set ws = y.Sheets.Add 
ws.Name = cll.Offset(0, -1).Text

 

[Jsingh96]

Set ws = y.Sheets.Add
ws.Name = cll.Offset(0, -1).Text

Perfect! Thanks a lot for your help - much appreciated

 

[DanteAmor]

I rewrote your macro to avoid the error handler, so that in case of error it can continue with the other sheets. Check if it is useful for you.

Sub CopyData()
  Dim wb1 As Workbook, wb2 As Workbook
  Dim cll As Range
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set wb1 = ThisWorkbook
  
  For Each cll In wb1.Sheets("data_pull").Range("E2:E33")
    If cell <> "" And cll.Offset(, -1) <> "" Then
      If Dir(cll.Value) <> "" Then
        Set wb2 = Workbooks.Open(cll.Value)
        If Evaluate("ISREF('[" & wb2.Name & "]data_paste'!A1)") Then
          On Error Resume Next
            wb1.Sheets(cll.Offset(, -1).Text).Delete
          On Error GoTo 0
          wb2.Sheets("data_paste").Copy after:=wb1.Sheets(wb1.Sheets.Count)
          With wb1.Sheets(wb1.Sheets.Count)
            .Name = cll.Offset(, -1).Text
            .Cells.Copy
            .Cells.PasteSpecial Paste:=xlPasteValues
          End With
        End If
        wb2.Close False
      End If
    End If
  Next
  
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

 

[Jsingh96]

I rewrote your macro to avoid the error handler, so that in case of error it can continue with the other sheets. Check if it is useful for you.

Sub CopyData()
  Dim wb1 As Workbook, wb2 As Workbook
  Dim cll As Range
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set wb1 = ThisWorkbook
 
  For Each cll In wb1.Sheets("data_pull").Range("E2:E33")
    If cell <> "" And cll.Offset(, -1) <> "" Then
      If Dir(cll.Value) <> "" Then
        Set wb2 = Workbooks.Open(cll.Value)
        If Evaluate("ISREF('[" & wb2.Name & "]data_paste'!A1)") Then
          On Error Resume Next
            wb1.Sheets(cll.Offset(, -1).Text).Delete
          On Error GoTo 0
          wb2.Sheets("data_paste").Copy after:=wb1.Sheets(wb1.Sheets.Count)
          With wb1.Sheets(wb1.Sheets.Count)
            .Name = cll.Offset(, -1).Text
            .Cells.Copy
            .Cells.PasteSpecial Paste:=xlPasteValues
          End With
        End If
        wb2.Close False
      End If
    End If
  Next
 
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

Hi thanks a lot for this tip - However, the code is not working now with the above change

 

[DanteAmor]

However, the code is not working now with the above change

And what doesn't work?
Send an error message?
What the message says?
Which line of the macro does it stop at?