# Copy ranges to new tabs with VBA



## EvdM (Dec 1, 2022)

Dear VBA Specialists,

I got myself a task where certain cells, defined by one row (A), needs to be automaticly copied to new tabs.
As example would I like to have 3 new created tabs with the range of A1:D4, A2:D6 and A7:D7. 






It would be much appreciated If you can help me with this VBA code.

Thanks in advance.


----------



## Micron (Dec 1, 2022)

Based on your limited information, here's one way, using sheet double click

```
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim ary As Variant
Dim i As Integer
Dim sht As Worksheet, sht2 As Worksheet

ary = Array("A1:D4", "A2:D6", "A7:D7")
Set sht = Sheets("D")
For i = 0 To UBound(ary)
     Set sht2 = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.count))
     sht2.Name = "00" & i + 1
     sht.Range(ary(i)).Copy sht2.Range("A1")
Next
Cancel = True
Set sht = Nothing
Set sht2 = Nothing

End Sub
```
Adapt above or research, such as 








						VBA Copy Range to Another Sheet + Workbook
					

this tutorial shows you how to use VBA to copy a cell or a range to another sheet in the same workbook (or even in another workbook).




					excelchamps.com
				



If you try to run again without deleting the sheets it creates you'll generate an error.


----------



## Peter_SSs (Dec 2, 2022)

Try to be clear and accurate with your questions.



EvdM said:


> row (A)


In Excel 'A' is a column, not a row. I assume that you mean column A?




EvdM said:


> with the range of A1:D*4*, A*2*:D6 and A7:D7


It looks to me like you probably really meant A1:D*3*, A*4*:D6, A7:D7.
If your originally quoted ranges are correct, then can you explain how you arrived at them?

Try this with a copy of your workbook.


```
Sub New_Sheets()
  Dim a As Variant
  Dim i As Long
  
  Application.ScreenUpdating = False
  a = Evaluate("unique(" & Range("A1", Range("A" & Rows.Count).End(xlUp)).Address & ")")
  Rows(1).Copy
  Rows(1).Insert
  With Range("A1").CurrentRegion
    For i = 1 To UBound(a)
      Sheets.Add After:=Sheets(Sheets.Count)
      .AutoFilter Field:=1, Criteria1:=a(i, 1)
      .Offset(1).Copy Destination:=Sheets(Sheets.Count).Range("A1")
    Next i
    .Rows(1).EntireRow.Delete
  End With
  Application.ScreenUpdating = True
End Sub
```


----------



## EvdM (Dec 2, 2022)

Thank you both for the quick response! This is a really good base to start with.
Sorry for the mistakes in the question but luckly you understood the task right.

What I forgot to mention is that there is also a header included.
I can get that header tab out by changing the A1 into A2. (see code)
Now I would like to change, that all the tabs include this header aswell.
And another nice feature to have is the name of column A, writen as the sheet name.

Do you know to to get that done? If so, can you please update this in the code.

Thanks in advance!


```
Sub New_Sheets()
  Dim a As Variant
  Dim i As Long
 
  Application.ScreenUpdating = False
  a = Evaluate("unique(" & Range("A2", Range("A" & Rows.Count).End(xlUp)).Address & ")")
  Rows(1).Copy
  Rows(1).Insert
  With Range("A1").CurrentRegion
    For i = 1 To UBound(a)
      Sheets.Add After:=Sheets(Sheets.Count)
      .AutoFilter Field:=1, Criteria1:=a(i, 1)
      .Offset(1).Copy Destination:=Sheets(Sheets.Count).Range("A1")
    Next i
    .Rows(1).EntireRow.Delete
  End With
  Application.ScreenUpdating = True
End Sub
```


----------



## Peter_SSs (Dec 2, 2022)

This assumes that column A values are all legal sheet name values and that sheets with these names do not already exist in the workbook.


```
Sub New_Sheets_v2()
  Dim a As Variant
  Dim i As Long
  
  Application.ScreenUpdating = False
  a = Evaluate("unique(" & Range("A2", Range("A" & Rows.Count).End(xlUp)).Address & ")")
  With Range("A1").CurrentRegion
    For i = 1 To UBound(a)
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = a(i, 1)
      .AutoFilter Field:=1, Criteria1:=a(i, 1)
      .Copy Destination:=Sheets(a(i, 1)).Range("A1")
    Next i
    .Parent.AutoFilterMode = False
    .Parent.Activate
  End With
  Application.ScreenUpdating = True
End Sub
```


----------



## EvdM (Dec 5, 2022)

Thank you a lot Peter!
That was exactly what I needed


----------



## Peter_SSs (Dec 5, 2022)

You're welcome. Thanks for the follow-up.


----------



## EvdM (Dec 5, 2022)

This might be a bit off-topic but I got this one last request.

The format of the created sheets is to narrow for showing the information and I would like to see all the data in the cells.
Is there a code to automatically resize the columns in all the created sheets?
and to adjust the first row (header) separately with *Bold *and colors in the filled-in cells?


----------



## Peter_SSs (Dec 5, 2022)

EvdM said:


> The format of the created sheets is to narrow for showing the information and I would like to see all the data in the cells.
> Is there a code to automatically resize the columns in all the created sheets?
> and to adjust the first row (header) separately with *Bold *...


Unless there is a particular reason not to, I would consider doing all of that in the original sheet before creating the new ones so it only has to be done once.


```
Sub New_Sheets_v3()
  Dim a As Variant
  Dim i As Long
  
  Application.ScreenUpdating = False
  a = Evaluate("unique(" & Range("A2", Range("A" & Rows.Count).End(xlUp)).Address & ")")
  With Range("A1").CurrentRegion
    .Rows(1).Font.Bold = True
    .Columns.AutoFit
    For i = 1 To UBound(a)
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = a(i, 1)
      .AutoFilter Field:=1, Criteria1:=a(i, 1)
      .Copy Destination:=Sheets(a(i, 1)).Range("A1")
    Next i
    .Parent.AutoFilterMode = False
    .Parent.Activate
  End With
  Application.ScreenUpdating = True
End Sub
```



EvdM said:


> .. and colors in the filled-in cells?


You would need to explain in more detail exactly what you mean by that.


----------



## EvdM (Dec 6, 2022)

Thanks Peter,

This code takes care of the Bold headers.
The last thing is the automatically resize of the columns.

Right now the new sheets are created like this: 



But what I like to have is all the data in the cells shown: 




Is that something that can be done in the code aswell?


----------



## EvdM (Dec 1, 2022)

Dear VBA Specialists,

I got myself a task where certain cells, defined by one row (A), needs to be automaticly copied to new tabs.
As example would I like to have 3 new created tabs with the range of A1:D4, A2:D6 and A7:D7. 






It would be much appreciated If you can help me with this VBA code.

Thanks in advance.


----------



## Peter_SSs (Dec 6, 2022)

EvdM said:


> The last thing is the automatically resize of the columns.
> 
> Is that something that can be done in the code aswell?


Yes, sorry, I thought that I had done that but clearly had not. 
Just add in this extra line.

```
Sub New_Sheets_v3()
  Dim a As Variant
  Dim i As Long
  
  Application.ScreenUpdating = False
  a = Evaluate("unique(" & Range("A2", Range("A" & Rows.Count).End(xlUp)).Address & ")")
  With Range("A1").CurrentRegion
    .Rows(1).Font.Bold = True
    .Columns.AutoFit
    For i = 1 To UBound(a)
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = a(i, 1)
      .AutoFilter Field:=1, Criteria1:=a(i, 1)
      .Copy Destination:=Sheets(a(i, 1)).Range("A1")
      *Sheets(a(i, 1)).UsedRange.Columns.AutoFit*
    Next i
    .Parent.AutoFilterMode = False
    .Parent.Activate
  End With
  Application.ScreenUpdating = True
End Sub
```


----------



## EvdM (Dec 6, 2022)

Thank you a lot Peter! This is very much appriciated.
Seems like it's ready to fill in the real data!


----------



## Peter_SSs (Dec 6, 2022)

You're welcome. Hope it does what is required with your real data!  🤞


----------



## EvdM (Dec 7, 2022)

It worked perfectly! Thanks a lot!

The only minor issue is that the pdfs are split up in 2 parts because of the width of the columns.
I've found the code to get that fixed through landscape but I'm not sure where to inplement this.
Do I put it in your code or rather in the save sheets macro (see code below)?

```
.PageSetup.Orientation = xlLandscape
```



```
Sub LoopSheetsSaveAsPDF()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    ws.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\" & ws.Name & ".pdf"
Next
End Sub
```

​


----------



## Peter_SSs (Dec 7, 2022)

EvdM said:


> Do I put it in your code ..


I's suggest give that a try and if no good then ..


EvdM said:


> ..or rather in the save sheets macro


----------



## EvdM (Dec 12, 2022)

Hi Peter,
I've tried it at multiple locations in the code and the outcome was no difference or this...





Can you figure it out how to make it work?


----------



## Peter_SSs (Dec 12, 2022)

EvdM said:


> I've tried it at multiple locations in the code and the outcome was no difference


This seemed to work for me


```
Sub LoopSheetsSaveAsPDF()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    *ws.PageSetup.Orientation = xlLandscape*
    ws.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\" & ws.Name & ".pdf"
Next
End Sub
```


----------



## EvdM (Dec 13, 2022)

Thanks again Peter!
The missing ws. was the problem.

I bumped into another issue that I can't find the awnser to.
Maybe you have a solution to fix this 

If I copy the data into the sheet, the url links stop to be hyperlinks.
When I select the cell and go out of it again, the hyperlinks get activated. (First 3 examples)
Do you know how to activate the hyperlinks with VBA?




Thanks in advance,
Edwin


----------



## Peter_SSs (Dec 14, 2022)

EvdM said:


> If I copy the data into the sheet ..


What data into what sheet?

Is this a manual copy or copy by code? If code, is it the code from post #11

(Either way, I am not experiencing that issue)


----------



## EvdM (Dec 16, 2022)

Hi Peter,

I'd imported the data of another sheet manually and bumped into that problem.
Afterwards have I created an import macro that still had the same problem...
But by some more searching did I found out that this was the solution.


```
Dim Cell As Range
For Each Cell In Range("J2", Range("J" & Rows.Count).End(xlUp))
    If Cell <> "" Then ActiveSheet.Hyperlinks.Add Cell, Cell.Value
Next
```

Now I got these last two issues before it's all ready.

The information is too wide for one page and not all the data is necceary in the tabs.
I would like the code to change the code so I can fill in the columns that will be pasted.
This could be written in the VBA so this will be the same columns every time. 


```
Sub CreateSheets()
  Dim a As Variant
  Dim i As Long
  
  Application.ScreenUpdating = False
  a = Evaluate("unique(" & Range("A2", Range("A" & Rows.Count).End(xlUp)).Address & ")")
  With Range("A1").CurrentRegion
    For i = 1 To UBound(a)
      Sheets.Add(After:=Sheets(Sheets.Count)).name = a(i, 1)
      .AutoFilter Field:=1, Criteria1:=a(i, 1)
      .Copy Destination:=Sheets(a(i, 1)).Range("A1")
      Sheets(a(i, 1)).UsedRange.Columns.AutoFit
    Next i
    .Parent.AutoFilterMode = False
    .Parent.Activate
  End With
  Application.ScreenUpdating = True
End Sub
```

And second, since the sheetnames can only store up to 31 characters and that will be not enough for these identificators.
I would like to base the filename on the value of a cell in this sheet. (Example Cell B2)
My best guess is to change de ws.name to something that is reffering to Cell B2 in the active worksheet.
How is that done the easiest way?


```
Sub SheetsToPDF()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    If Not ws.name = "Sheet1" Then
        ws.PageSetup.Orientation = xlLandscape
        ws.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ThisWorkbook.path & "\" & [COLOR=rgb(184, 49, 47)]ws.name[/COLOR] & ".pdf"
End If
Next
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
    If Not ws.name = "Sheet1" Then
    ws.Delete
End If
Next ws
Application.DisplayAlerts = True
End Sub
```

Can you please help me this last time 
Thank you very much in advance!


----------



## EvdM (Dec 1, 2022)

Dear VBA Specialists,

I got myself a task where certain cells, defined by one row (A), needs to be automaticly copied to new tabs.
As example would I like to have 3 new created tabs with the range of A1:D4, A2:D6 and A7:D7. 






It would be much appreciated If you can help me with this VBA code.

Thanks in advance.


----------



## EvdM (Dec 22, 2022)

Hi Peter,

I've fixed one issue myself with a Vlookup like this:

```
Sub SheetsToPDF()
Dim ws As Worksheet
Dim SheetName As String

For Each ws In ActiveWorkbook.Worksheets
    If Not ws.Name = "Sheet1" Then
        SheetName = Application.VLookup(ws.Name, Sheet1.Range("A1:K1000"), 11, False)
        ws.PageSetup.Orientation = xlLandscape
        ws.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\" & SheetName & ".pdf"
End If
```

But the other issue is an adjustment in your code that I don't understand enough to make changes.
Could you please update the code so it only copies the first 8 columns instead of every column out of the mainsheet. 


```
Sub CreateSheets()
  Dim a As Variant
  Dim i As Long
  
  Application.ScreenUpdating = False
  a = Evaluate("unique(" & Range("A2", Range("A" & Rows.Count).End(xlUp)).Address & ")")
  With Range("A1").CurrentRegion
    For i = 1 To UBound(a)
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = a(i, 1)
      .AutoFilter Field:=1, Criteria1:=a(i, 1)
      .Copy Destination:=Sheets(a(i, 1)).Range("A1")
      Sheets(a(i, 1)).UsedRange.Columns.AutoFit
    Next i
    .Parent.AutoFilterMode = False
    .Parent.Activate
  End With
  Application.ScreenUpdating = True
End Sub
```

Thanks in Advance,
Edwin


----------



## Peter_SSs (Dec 22, 2022)

EvdM said:


> Could you please update the code so it only copies the first 8 columns instead of every column out of the mainsheet.


Try this change

```
*.Copy Destination:=Sheets(a(i, 1)).Range("A1")
.Resize(, 8)*.Copy Destination:=Sheets(a(i, 1)).Range("A1")
```


----------



## EvdM (Dec 23, 2022)

That was exactly the anwser that I was looking for! Thank you a lot Peter! 
Enjoy Chistmas and already the best wishes for the new year


----------



## Peter_SSs (Dec 23, 2022)

You're welcome. Season's greetings to you too.


----------

