VBA newbie, I am trying to find a way to increase the number of tabs or sheets by copying the last one and then renumbering it. i.e copying tab 150 then relabeling it 151 and so on.
I've figured out a way to copy the sheet with the code below:
Sub CopySheetRename1()
Sheets("150").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "LastSheet"
End Sub
But i can't get the new sheet to rename itself.
Any help is appreciated
This perhaps. It's not clear if you have only sheets numbered or others.
Sub CopySheetRename1()
Dim ws As Worksheet
Set ws = Worksheets(Worksheets.Count)
ws.Copy After:=ws
If IsNumeric(ws.Name) Then ActiveSheet.Name = CLng(ws.Name) + 1
End Sub
Try this :
Sub Loadsoftabscreations() 'as many as you want :)
Worksheets("Sheet150").Select
For x = 1 To 300 ' or as many new fresh tabs you want
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "YourTab - " & x
Next x
End Sub
You can set the names in the code as you want.
as per my comment, for copying x number of times:
Sub LoadsoftabscreationsC()
Dim ws As Worksheet
Set ws = Worksheets(Worksheets.Count)
For x = 1 To 10 ' or as many as needed
ws.Copy After:=ws
If IsNumeric(ws.Name) Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name
Next x
End Sub
Related
I have a workbook that crashes often. I suspect it's corrupted. So, I wrote the following code to copy it sheet by sheet to a new workbook. The size of the new workbook is now 40% less. Everything seems to work fine except the code doesn't copy tables. ListObjects doesn't seem to have a count property. So, it's not straight forward to detect the number of tables in a sheet.
How do I detect the existence, size, and location of tables? Once that info is known, I think it'd be quite easy to go to the target sheet and add tables. Thanks in advance for any help.
Sub copy_all()
'copy sheet by sheet from myworkbook.xlsb to the calling workbook
Dim rng As Range
Dim i As Integer
With Workbooks("myworkbook.xlsb")
For i = 1 To .Sheets.Count
Set rng = .Sheets(i).UsedRange
ThisWorkbook.Sheets(i).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Cells.Value = rng.Cells.Value
ThisWorkbook.Sheets(i).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Cells.Formula = rng.Cells.Formula
ThisWorkbook.Sheets(i).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Cells.ColumnWidth = rng.Cells.ColumnWidth
rng.Copy
ThisWorkbook.Sheets(i).Range("A1").PasteSpecial Paste:=xlPasteFormats
ThisWorkbook.Sheets(i).Name = .Sheets(i).Name
ThisWorkbook.Sheets(i).Tab.ColorIndex = .Sheets(i).Tab.ColorIndex
Next i
End With
End Sub
Try the next code, to find the ListObjects and their range address, please:
Sub testAllListObjects()
Dim T As ListObject, sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
If sh.ListObjects.Count > 0 Then
For Each T In sh.ListObjects
Debug.Print sh.Name, T.Name, T.Range.address
Next
End If
Next
End Sub
Continuing the question:
TextBox object customisation - Compile error: Invalid or unqualified reference
I am going to copy this element - textbox into all worksheets throughout my document.
I would like to have it exactly in the same place in each worksheet.
For this purpose I used the code:
Sub Asbuildcopy()
Dim wsh As Worksheet
Dim ArraySheets As String
Dim x As Variant
For Each wsh In ActiveWorkbook.Worksheets
ActiveSheet.Shapes("Textbox 3").Copy
Application.Goto Sheets(ArraySheets).Range("Q6")
ActiveSheet.Paste
ArraySheets(x) = wsh.Name
x = x + 1
End Sub
According to the advice here:
https://www.ozgrid.com/forum/index.php?thread/73851-copy-shape-to-cell-on-another-worksheet/
https://i.stack.imgur.com/lOhJj.png
stating about copying an element into another sheet.
Apart from my code, one problem is the location of this element. I used target cell as Q6, but I would like to have it exactly in the same place as on the 1st (initial) sheet.
Thank you for your hint,
Try this. As per comment, can use the Top and Left properties of a shape to position it as per the first sheet.
Use more meaningful procedure and variable names for your actual code.
Sub x()
Dim ws As Worksheet, ws1 As Worksheet, s As Shape
Set ws1 = Worksheets("Sheet1") 'sheet containing original textbox
Set s = ws1.Shapes("TextBox 3") 'name of original textbox
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
s.Copy
ws.Paste
ws.Shapes(ws.Shapes.Count).Top = s.Top
ws.Shapes(ws.Shapes.Count).Left = s.Left
End If
Next ws
Application.ScreenUpdating = True
End Sub
I am trying to create a code that will duplicate and rename a template tab named "001". The thing is, I want each duplicated tab to be named as "001 +1". So the duplicated tabs' names would be "002,003,...,010,011...100,101, etc.
The number of duplicates will be decided by the number entered into a message box that will appear asking "How many copies would you like to make?". Also I would like for there to be no duplicates or tabs named "001 (2)" if more tab copies were to be added at a later time.
I really appreciate your help.
Here's one way to do it:
Sub Tester()
CreateSheets 4
End Sub
'EDIT: added specific workbook reference to qualify sheet references
Sub CreateSheets(howMany As Long)
Dim nm As String, sht As Worksheet
Dim i As Long, n As Long, wb As Workbook
Set wb = ThisWorkbook
For n = 1 To howMany
i = 2
Do
nm = Format(i, "000")
Set sht = Nothing
'see if this sheet exists...
On Error Resume Next
Set sht = wb.Sheets(nm)
On Error GoTo 0
If sht Is Nothing Then
'get the sheet to copy the template after
Set sht = wb.Sheets(Format(i - 1, "000"))
wb.Sheets("001").Copy after:=sht
wb.Sheets(sht.Index + 1).Name = nm
Exit Do 'made our copy
End If
i = i + 1
Loop
Next n
End Sub
I'd like to find the position of a worksheet as it is displayed in a workbook.
For example, assume I have a workbook starting with Sheet1, Sheet2 and Sheet3 in that order. Then a user drags Sheet2 to left, before Sheet1.
I want Sheet2 to return 1, Sheet1 to return 2 (and Sheet3 still to return 3).
I can't find a way to determine this in VBA.
This should do it:
Worksheets("Sheet1").Index
https://msdn.microsoft.com/en-us/library/office/ff836415.aspx
You can just iterate the Worksheets collection of the Workbook object. You can test yourself by running the following code, switch the order around in the UI, then run it again:
Option Explicit
Sub IterateSheetsByOrder()
Dim intCounter As Integer
Dim wb As Workbook
Set wb = ThisWorkbook
For intCounter = 1 To wb.Worksheets.Count
Debug.Print wb.Worksheets(intCounter).Name
Next intCounter
End Sub
To loop through all worksheets in a workbook use For Each WS in ThisWorkbook.Worksheets where WS is a worksheet object. Hence to obtain order of Excel worksheets as shown, we may also use the following code:
Sub LoopThroughWorksheets()
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
Debug.Print WS.Name
Next
End Sub
To obtain an output like Worksheets("Sheet1").Index then you may use this code
Sub IndexWorksheet()
Dim WS As Worksheet, n As Long
For Each WS In ThisWorkbook.Worksheets
n = n + 1
If WS.Name = "Sheet1" Then Debug.Print n
Next
End Sub
You can use the Sheets object. In your example, reading Sheets(2).Name should return Sheet1.
Right answer provided by Anastasiya-Romanova, but missing some important details.
There are two methods of doing this. First, with a For Each loop:
Sub ListSheetNames()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Debug.Print ws.Name
Next ws
End Sub
Second, with a basic For loop:
Sub ListSheetNames
Dim i As Long
For i = 1 to ThisWorkbook.Worksheets.Count
Debug.Print ThisWorkbook.Worksheets(i).Name
Next i
End Sub
You will find the second method will always output the names in the sheet index order, which is generally the order the sheets were created in unless you change the index. Simply rearranging the sheets from the workbook window won't change the index.
Therefore, the first method is the correct way to do this. It will always follow the tab order as you see on your screen.
Below code works even if sheet is renamed or its sequence is changed.
Sub Display_Sheet_Tab_Number()
Dim WorksheetName As String
Dim n As Integer
WorksheetName = Sheet1.Name
MsgBox Worksheetname
n = Sheets(WorksheetName).Index 'n is index number of the sheet
MsgBox "Index No. = " & n
End Sub
I have two workbooks, with same sheets name (but in different order), and I'd like to copy info of all of the sheets of one workbook, and pasting that info in the respective sheet of the other workbook (matching sheet names). I feel like this code is on track, but maybe there is a more efficient or cleaner way to do this. Code is working, but it says a warning like " there's a big amount of data in the windows clipboard... etc... "
Sub ActualizarNoticias()
Dim aw As Workbook
Dim y As Workbook
Set aw = Application.ActiveWorkbook
Set y = Application.Workbooks.Open("G:\Estudios\Biblioteca\Mercado Accionario Chileno\BBDD Oficial.xlsm")
For i = 1 To aw.Sheets.Count
For j = 1 To y.Sheets.Count
If aw.Worksheets(i).Name = y.Worksheets(j).Name Then
y.Worksheets(j).Range("A3").Copy
aw.Worksheets(i).Range("A100").PasteSpecial
End If
Next j
Next i
y.close
' ActualizarNoticias Macro
'
'
End Sub
I am not sure how much data you intend to copy, or where in the target workbook you want to copy to, but the code you posted only copies one cell (A3) and copies it into the target workbook in cell A100. I gather your code is only an example, because surely the warning would not come for copying a single cell. It would help to have your actual ranges, and exact warning message, but as you said, it's working. Are you getting the message when you run the code, or when you exit the workbook? If the latter (as I suspect), then you can simply clear the clipboard at the end of your code:
Application.CutCopyMode = False
You can also eliminate the second loop with a little trickery:
Set sh = Nothing
On Error Resume Next
Set sh = y.Worksheets(aw.Worksheets(i).Name)
On Error GoTo 0
If TypeName(sh) <> "Nothing" Then
....
End If
My entire subroutine looks as follows:
Sub CopyWorkbook()
Dim aw As Workbook
Dim y As Workbook
Dim sh As Worksheet
Set aw = Application.ActiveWorkbook
Set y = Application.Workbooks.Open("C:\work\fusion\expenseTypes.xls.xlsx")
For i = 1 To aw.Sheets.Count
Set sh = Nothing
On Error Resume Next
Set sh = y.Worksheets(aw.Worksheets(i).Name)
On Error GoTo 0
If TypeName(sh) <> "Nothing" Then
sh.Range("A:C").Copy aw.Worksheets(i).Range("A1")
End If
Next i
Application.CutCopyMode = False
End Sub
I think this is the most efficient way to do it. My sample code above copies entire columns (A through C), which preserves column formatting, so that it's not necessary to re-adjust your new workbook for the column widths.