We have a workbook that needed to have the sheets change names every month and I decided to automate it for other employees. So after some research I found the best way to do it was to reference the names of cells. I needed it to start running on the 4th sheet and run through the second last sheet. I found some VBA code and edited it until I got to this point:
Sub RenameSheet()
Dim ShCnt As Integer 'count of sheets in workbook
Dim myarray() As String 'array of new worksheet names
Dim Month() As String 'mystery variable -- not used in this code
Dim i As Integer 'loop counter
Dim Lrow As Integer 'number of new worksheet names.
ThisWorkbook.Sheets("SETUP").Select 'select the sheet that has the list of new names
Lrow = Range("T1").End(xlDown).Row 'get range that contains new worksheet names
ShCnt = ThisWorkbook.Sheets.Count 'get number of worksheets in the workbook
ReDim myarray(1 To Lrow) 'resize array to match the number of new worksheet names
For i = 1 To UBound(myarray) 'loop through array of new sheet names
myarray(i) = Range("T" & i).Value 'insert new sheet name into array
Debug.Print Range("T" & i).Value 'show the new worksheet name in 'the Immediate window to be able to check that we're getting what we want
Next i 'end of loop
For i = 4 To ShCnt - 1 'loop through array of existing worksheets
Sheets(i).Name = myarray(i) 'rename each worksheet with the matching name from myarray
Next i 'end of loop
MsgBox "Sheets name has changed successfully" 'report success
End Sub
My issue is that I need the 4th sheet to start with the value in cell "T2". I have figured out that this section of code changed the starting point:
For i = 1 To UBound(myarray)
myarray(i) = Range("T" & i).Value
Debug.Print Range("T" & i).Value
Next i
When I replaced myarray(i) = Range("T" & i).Value with myarray(i) = Range("T2" & i).Value it started on cell T24 for some reason (which may have to do with the placement of my button?) and myarray(i) = Range("T" + 1 & i).Value doesn't work.
I also tried changing the For i = 1 To UBound(myarray) to For i = 2 To UBound(myarray) and that didn't work either.
Can someone please help me figure out how to get it so that the information in cell T2 ends up on the 4th sheet and goes from there? Thank you very much in advance.
I would suggest loop through worksheets in the workbook and use the loop counter to index into the range of names in column T:
Sub RenameSheet()
Dim ShCnt As Integer
Dim i As Integer
Dim ws_setup As Worksheet
Set ws_setup = ThisWorkbook.Worksheets("SETUP")
ShCnt = ThisWorkbook.Worksheets.Count
Const start_ws_index = 4
For i = start_ws_index To ShCnt - 1
ThisWorkbook.Worksheets(i).Name = _
ws_setup.Range("t2").Offset(i - start_ws_index, 0).Value
Next i
End Sub
Rename Sheets From List
In the current setup, it is assumed that the list is contiguous (no blanks), has at least two entries, and starts in cell T2, and that the 4th sheet is the first to be renamed.
The Code
Option Explicit
Sub renameSheets()
' Constants
Const wsName As String = "SETUP"
Const FirstCell As String = "T2"
Const FirstSheetIndex As Long = 4
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Array (at least two names)
Dim SheetNames As Variant
With wb.Worksheets(wsName)
SheetNames = .Range(FirstCell, .Range(FirstCell).End(xlDown))
End With
' Rename
Dim shOffset As Long: shOffset = FirstSheetIndex - 1
Dim i As Long
For i = 1 To UBound(SheetNames, 1)
wb.Sheets(i + shOffset).Name = SheetNames(i, 1)
Next i
' Inform
MsgBox "Sheet names changed successfully", vbInformation
End Sub
Related
Suppose you have an excel workbook with 30 sheets, and you would like to extract data from the range A1:K40 from every sheet into that workbook, and then add all of the extracted data into a single excel sheet in a different workbook. Would this be possible?
I would like to build it such that the user is prompted to select a file, and the file selected will be of the same format, a workbook with 28-31 sheets, and complete the function as previously stated. An additional feature I'd like to add would be when the user selects the workbook, they will be prompted to select which sheets to extract data from within that workbook.
I'd appreciate if anyone could direct me to similar example or even better, just guide me on which vba functions would be best to make this work.
Please, try the next way. It will create a string composed by concatenation of all sheets name with their index and the user is asked to choose the index of sheets to have ranges copied. They should choose them writing the index separated by comma (2,5,9,12). In case of more consecutive sheets, they can use 2,5,9-12,15, 9-12 meaning sheets form 9 to 12 (9,10,11,12). You should configurate the code using the sheets name where the ranges to be copied **instead "AllSheets" generically used in the code):
Sub CopySomeSheets()
Dim wbC As Workbook, wb As Workbook, ws As Worksheet, wsCopy As Worksheet, lastR As Long
Dim strAllSheets As String, strSelSheets As String, arrSheets, i As Long
Set wbC = ActiveWorkbook 'use here the workbook where from to copy sheets
Set wb = ThisWorkbook 'use here the workbook where to copy all ranges
Set ws = wb.Worksheets("AllSheets") 'the sheet where all ranges should be pasted!!!
'create the list of all sheets from whitch to choose the ones to be copied:
For i = 1 To wbC.Sheets.count
strAllSheets = strAllSheets & wbC.Sheets(i).name & " - " & i & vbCrLf
Next i
strSelSheets = InputBox("Please, select the sheets to be copied." & vbCrLf & _
"Use the sheets number (after its name) separated by comma ("","")." & vbCrLf & _
"More consecutive sheets should be represented as ""5-8"", which means sheets 5,6,7,8." & _
vbCrLf & vbCrLf & strAllSheets, _
"Make sheets selection")
If strSelSheets = "" Then MsgBox "You did not select any sheet...": Exit Sub 'in case of pressing Cancel or Top right X
arrSheets = makeSheetsArray(Split(Replace(strSelSheets, " ", ""), ","), wbC) 'make an array of sheets indexes
'copy the ranges from above selected sheets:
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual 'a little optimization
For i = 0 To UBound(arrSheets)
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row 'lastr row on A:A
If lastR > 1 Then lastR = lastR + 1 'first range is copying starting from A1, the rest in the next empty row
wbC.Worksheets(CLng(arrSheets(i))).Range("A1:K40").Copy ws.Range("A" & lastR) 'copy the range
Next i
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Ready..."
End Sub
Function makeSheetsArray(arr, wb As Workbook) As Variant 'it makes an array of all selected sheets (split x-y cases)
Dim arrFin, arr_, k As Long, i As Long, j As Long
ReDim arrFin(wb.Sheets.count) 'maximum possible number of sheets
For i = 0 To UBound(arr)
If InStr(arr(i), "-") > 0 Then 'for the case of x-y:
arr_ = Application.Evaluate("ROW(" & Replace(arr(i), "-", ":") & ")") ' 2D array base 1
For j = 1 To UBound(arr_)
arrFin(k) = arr_(j, 1): k = k + 1
Next j
Else
arrFin(k) = arr(i): k = k + 1
End If
Next i
ReDim Preserve arrFin(k - 1)
makeSheetsArray = arrFin
End Function
Please, send some feedback after testing it.
If something not clear enough, do not hesitate to ask for clarifications...
I am copying data under columns with matching headers between the source sheet and the destination sheet. Both the sheets are in the same excel file but they need to have a clarification number.
For example, one of the columns in the destination sheet has the the clarification number QM6754 and the row of data of QM6754. The source sheet also has the clarification number column but I dont want to copy it, I want to copy the other data in the row of this specific clarification number to the destination sheet that in one of its columns. this way the data isn't copied randomly and the entire row from each sheet relate to each other.
The code I used shows results(I modified it) but when I run it, the excel file shows (not responding) for about 3-4 minutes and then shutsdown or leaves a blank Excel sheet and VBA window. I close the excel file and reopen it and the data has been copied. The file is quite large and I have three pushbuttons that run this code for each sheet I want to copy data from. Three sheets with average of 3k-6k rows. But I cannot eliminate the rows.
The code runs but I would like to optimize of the way it runs because it isn't practical to run, close file and then open file again. Could the issue be with the For loop?
Sub CopyColumnData()
Dim wb As Workbook
Dim myworksheet As Variant
Dim workbookname As String
' DECLARE VARIABLES
Dim i As Integer ' Counter
Dim j As Integer ' Counter
Dim colsSrc As Integer ' PR Report: Source worksheet columns
Dim colsDest As Integer ' Open PR Data: Destination worksheet columns
Dim rowsSrc As Long ' Source worksheet rows
Dim WsSrc As Worksheet ' Source worksheet
Dim WsDest As Worksheet ' Destination worksheet
Dim ws1PRRow As Long, ws1EndRow As Long, ws2PRRow As Long, ws2EndRow As Long
Dim searchKey As String, foundKey As String
workbookname = ActiveWorkbook.Name
Set wb = ThisWorkbook
myworksheet = "Sheet 1 copied Data"
wb.Worksheets(myworksheet).Activate
' SET VARIABLES
' Source worksheet: Previous Report
Set WsSrc = wb.Worksheets(myworksheet)
Workbooks(workbookname).Sheets("Main Sheet").Activate
' Destination worksheet: Master Sheet
Set WsDest = Workbooks(workbookname).Sheets("Main Sheet")
'Adjust incase of change in column in both sheets
ws1ORNum = "K" 'Clarification Number
ws2ORNum = "K" 'Clarification Number
' Setting first and last row for the columns in both sheets
ws1PRRow = 3 'The row we want to start processing first
ws1EndRow = WsSrc.UsedRange.Rows(WsSrc.UsedRange.Rows.Count).Row
ws2PRRow = 3 'The row we want to start search first
ws2EndRow = WsDest.UsedRange.Rows(WsDest.UsedRange.Rows.Count).Row
For i = ws1PRRow To ws1EndRow ' first and last row
searchKey = WsSrc.Range(ws1ORNum & i)
'if we have a non blank search term then iterate through possible matches
If (searchKey <> "") Then
For j = ws2PRRow To ws2EndRow ' first and last row
foundKey = WsDest.Range(ws2ORNum & j)
' Copy result if there is a match between PR number and line in both sheets
If (searchKey = foundKey) Then
' Copying data where the rows match
WsDest.Range("AI" & j).Value = WsSrc.Range("A" & i).Value
WsDest.Range("AJ" & j).Value = WsSrc.Range("B" & i).Value
WsDest.Range("AK" & j).Value = WsSrc.Range("C" & i).Value
WsDest.Range("AL" & j).Value = WsSrc.Range("D" & i).Value
WsDest.Range("AM" & j).Value = WsSrc.Range("E" & i).Value
WsDest.Range("AN" & j).Value = WsSrc.Range("F" & i).Value
WsDest.Range("AO" & j).Value = WsSrc.Range("G" & i).Value
WsDest.Range("AP" & j).Value = WsSrc.Range("H" & i).Value
Exit For
End If
Next
End If
Next
'Close Initial PR Report file
wb.Save
wb.Close
'Pushbuttons are placed in Summary sheet
'position to Instruction worksheet
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
End Sub
To increase the speed and reliability, you will want to handle the copy/paste via array transfer instead of the Range.Copy method. Given your existing code, here's how a solution that should work for you:
Sub CopyColumnData()
'Source data info
Const sSrcSheet As String = "Sheet 1 copied Data"
Const sSrcClarCol As String = "K"
Const lSrcPRRow As Long = 3
'Destination data info
Const sDstSheet As String = "Main Sheet"
Const sDstClarCol As String = "K"
Const lDstPRRow As Long = 3
'Set variables based on source and destination
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Worksheets(sSrcSheet)
Dim wbDst As Workbook: Set wbDst = ActiveWorkbook
Dim wsDst As Worksheet: Set wsDst = wbDst.Worksheets(sDstSheet)
On Error GoTo 0
'Verify source and destination were found
If wsSrc Is Nothing Then
MsgBox "Worksheet """ & sSrcSheet & """ not found in " & wbSrc.Name
Exit Sub
End If
If wsDst Is Nothing Then
MsgBox "Worksheet """ & sDstSheet & """ not found in " & wbDst.Name
Exit Sub
End If
'Setup variables to handle Clarification Number matching and data transfer via array
Dim hDstClarNums As Object: Set hDstClarNums = CreateObject("Scripting.Dictionary") 'Clarification Number Matching
'Load Source data into array
Dim rSrcData As Range: Set rSrcData = wsSrc.Range(sSrcClarCol & lSrcPRRow, wsSrc.Cells(wsSrc.Rows.Count, sSrcClarCol).End(xlUp))
Dim aSrcClarNums() As Variant: aSrcClarNums = rSrcData.Value
Dim aSrcData() As Variant: aSrcData = Intersect(rSrcData.EntireRow, wsSrc.Columns("A:H")).Value 'Transfer data from columns A:H
'Prepare dest data array
Dim rDstData As Range: Set rDstData = wsDst.Range(sDstClarCol & lDstPRRow, wsDst.Cells(wsDst.Rows.Count, sDstClarCol).End(xlUp))
Dim aDstClarNums() As Variant: aDstClarNums = rDstData.Value
Dim aDstData() As Variant: aDstData = Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value 'Destination will be into columns AI:AP
'Use dictionary to perform Clarification Number matching
Dim vClarNum As Variant
For Each vClarNum In aDstClarNums
If Not hDstClarNums.Exists(vClarNum) Then hDstClarNums.Add vClarNum, hDstClarNums.Count + 1
Next vClarNum
'Transfer data from source to destination using arrays
Dim i As Long, j As Long
For i = 1 To UBound(aSrcClarNums, 1)
For j = 1 To UBound(aSrcData, 2)
If hDstClarNums.Exists(aSrcClarNums(i, 1)) Then aDstData(hDstClarNums(aSrcClarNums(i, 1)), j) = aSrcData(i, j)
Next j
Next i
'Output to destination
Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value = aDstData
'Save and close source workbook (uncomment next line if this is necessary)
'wbSrc.Close SaveChanges:=True
'Activate summary sheet, cell A1 in destination workbook (uncomment these lines if this is necessary)
'wbDst.Worksheets("Summary").Activate
'wbDst.Worksheets("Summary").Range("A1").Select
End Sub
I would like to auto-populate new sheets in Excel with their names based on the cell value. However, it won't be the value from one cell but from the list of cells in the row. The name of the first worksheet will be fetched from the 1st cell value, the name of the second worksheet from the 2nd cell value, and so on...
I defined the maximum range of these cells - 20 in the row, but not all of them will have the values. I want the new sheets to be created only from these cells, where value is provided.
I used the following code:
Sub Namedsheetsadding()
Dim wsr As Worksheet, wso As Worksheet
Dim i As Long, xCount As Long
Dim SheetName As String
Set wsr = ThisWorkbook.Sheets("Vetro Area Map 1")
SheetName = ThisWorkbook.Sheets("Frontsheet").Range("D122:D142") 'including empty cells either, but
not creating new sheets for them
For i = 1 To ActiveWorkbook.Sheets.Count
If InStr(1, Sheets(i).name, "Vetro") > 0 Then xCount = xCount + 1
Next
wsr.Copy After:=ActiveWorkbook.Sheets(wsr.Index - 1 + xCount)
ActiveSheet.name = "Vetro Area Map " & SheetName & xCount + 1
End Sub
Based on some solutions here:
VBA rename sheet based on cell value
http://excelexperts.com/vba-code-adding-new-sheet-based-cell-value
https://www.mrexcel.com/board/threads/vba-create-new-sheet-based-on-cell-data.740895
EXCEL VBA Dynamic Sheet Name according to a cell value - Not working when formula in the cell
which apply to one cell only
Possibly this is the reason, why I am getting:
Error: Type mismatch
for the following line:
SheetName = ThisWorkbook.Sheets("Frontsheet").Range("D122:D142") 'including empty cells either, but not creating new sheets for them
Is there any chance to make the sheet auto-population with names based on the cell range?
This should do what you are looking for,it gets an array from the range, converts it into a 1d array and then makes the sheets.
Sub Namedsheetsadding()
Dim wsr As Worksheet, wso As Worksheet
Dim i As Long, xCount As Long
Dim SheetNames As Variant 'This needs to be variant
Dim sheetname As Variant
Dim newsheet As Worksheet
Dim lr As Long
Set wsr = ThisWorkbook.Sheets("Vetro Area Map 1")
lr = ThisWorkbook.Sheets("Frontsheet").Cells(Rows.Count, 4).End(xlUp).Row 'Get last row
SheetNames = ThisWorkbook.Sheets("Frontsheet").Range("D122:D" & lr) 'including empty cells either, but not creating new sheets for them
SheetNames = Application.Transpose(Application.Index(SheetNames, , 1)) 'Converts the 2d array into a 1d array
For i = 1 To ActiveWorkbook.Sheets.Count
If InStr(1, Sheets(i).Name, "Vetro") > 0 Then xCount = xCount + 1
Next
For Each sheetname In SheetNames
wsr.Copy After:=ActiveWorkbook.Sheets(wsr.Index - 1 + xCount)
Set newsheet = Sheets(wsr.Index + xCount)
newsheet.Name = "Vetro Area Map " & sheetname
xCount = xCount + 1 'Preserve order of sheets from range
Next
End Sub
In answer to your question, YES, you can make sheets automatically named, but you'll need to handle your rules better. You're getting an error because you're trying to reference an array to a single string. I would recommend learning about arrays (Paul Kelly has some great stuff here), but there might be other ways to approach your specific issue.
If you're more familiar with Excel than VBA, you should try to make a cell formula rule that populates a SINGLE cell that should be the next name of a worksheet. If you can have a cell that will always have the proper name, then you can always have your code reference the same value.
Alternatively, you might want to use the VBA offset function, which is pretty easier for newer coders to comprehend.
See below as an example.
Sub makeNewWorksheets()
Dim wsr As Worksheet, wso As Worksheet
Dim i As Long, xCount As Long
Dim SheetName As String
Dim startTingCell As Range
Set startTingCell = Range("D122")
For i = 1 To ActiveWorkbook.Sheets.Count
If InStr(1, Sheets(i).Name, "Vetro") > 0 Then xCount = xCount + 1
Next
'Changes the cell being referenced by xCount
Set startTingCell = startTingCell.Offset(xCount, 0)
'helps explain what is happening. Delete after you've grasped what's up.
MsgBox "The cell that will be set to the name is " & startTingCell.Address & _
"with a value of " & startTingCell.Value
wsr.Copy After:=ActiveWorkbook.Sheets(wsr.Index - 1 + xCount)
ActiveSheet.Name = "Vetro Area Map " & startTingCell.Value
End Sub
I need help and I'm hoping someone here can help me :)
I have a workbook that runs some reports from Avaya CMS. It runs the report and creates a new sheet for each persons name on the MAIN sheet. << This part works wonderfully.
My issue is I cannot figure out how to use that range of names on the MAIN sheet to select only those specific sheets and then copy them to a new workbook.. There's 2 other hidden sheets as well.. Which is why I think using the range of names is easier but I'm open to anything at this point.
Here's an screeshot of what it looks like :
Sorry, I couldn't figure out how to upload the workbook here but the image should, hopefully, be good enough. Thank you for your time and help!
Here's an image with the hidden sheets.
I need it to exclude the first 3 sheets/
And here's the code:
Sub Macro1()
Dim sheetArray() As String
Dim i As Integer
i = 0
For Each c In MainSheet.Range("A2:A20").Cells
ReDim Preserve sheetArray(0 To i)
sheetArray(i) = c.Value
i = i + 1
Next
Sheets(sheetArray).Select
End Sub
Sub move_Sheets()
Dim mSH As Worksheet
Set mSH = ThisWorkbook.Sheets("Main")
Dim shArray() As String
Dim i As Integer
i = mSH.Range("A" & Rows.Count).End(xlUp).Row
ReDim Preserve shArray(0 To i - 2)
For a = 2 To i
shArray(a - 2) = mSH.Range("A" & a).Value
Next a
ThisWorkbook.Sheets(shArray).Move
End Sub
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, sheetIndex As Long
Dim SheetName As String
Dim ws As Worksheet
With ThisWorkbook.Worksheets("Main")
'Last row of column where the names appears
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop the column from row 2 to last row
For i = 2 To LastRow
'Set Sheet name
SheetName = .Range("A" & i).Value
'Check if the sheet with the SheetName exists
If DoesSheetExists(SheetName) Then
'Insert the code to code
sheetIndex = Workbooks("Book2").Sheets.Count
ThisWorkbook.Worksheets(SheetName).Copy After:=Workbooks("Book2").Sheets(sheetIndex)
Else
End If
Next i
End With
End Sub
Function DoesSheetExists(SheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(SheetName)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
I've been recently getting back into VBA and have been testing out a concept of Adding Worksheets by the string in a variable. I've been able to get the worksheets to add successfully and the last two lines of my code are simply to select the sheet name of the variable and then select cell A + the row number that is stored in another variable
In Sheet1, Column A, starting in A1, I have a list of 8 different names that cycles through:
Bob
Jeff
Max
Steve
Rosie
Pippa
Penelope
Rob
I am expecting the macro to end on Sheet "Rob" with cell A9 selected, however i get a runtime 1004 error
I have stepped through the code and it is selecting the sheet correctly with the variable, but when it tries to select row A9, the error presents
My code is below:
Sub Add_worksheets()
Dim sheetName As String
Dim rownum As Integer
rownum = 1
Range("A" & rownum).Select
sheetName = ActiveCell.Value
Do Until Range("A" & rownum).Value = ""
Range("A" & rownum).Select
sheetName = CStr(ActiveCell.Value)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName
Sheets("sheet1").Select
rownum = rownum + 1
Loop
Sheets(sheetName).Select
Range("A" & rownum).Select
End Sub
Any help would be greatly appreciated
I also suggest you add if-else to check if the sheet name exists.. Why do you want to select? I do not support selections, since you need it you may try this: Because when you are incrementing rownum it goes to 10th cell, that means, Sheetname no longer has a name but empty..
Dim sheetName As String
Dim rownum As Integer
Dim WS as WorkSheet
rownum = 1
sheetName = Range("A" & rownum).Value '-- remove select
Do Until Range("A" & rownum).Value = ""
Range("A" & rownum).Select
sheetName = CStr(ActiveCell.Value)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetName
Set WS = Sheets(sheetName)
Sheets("sheet1").Select
rownum = rownum + 1
Loop
rownum = rownum - 1 '-- here
WS.Activate
Range("A" & rownum).Value = rownum
Or you may just use an array to do the creation of the sheets and then select a sheet later....Instead of going back and forth to first sheet...with names..
Sub addSheets()
Dim rowNum as Integer
Dim Ws as WorkSheet
Dim vArray as Variant
'-- creates one dimensional array
vArray = WorkSheetFunction.Transpoe(Sheets(1).Range("A1:A9"))
For rownum = Lbound(vArray) to Ubound(vArray)
If IsEmpty(vArray(rowNum)) Then
On Error Resume Next
Set Ws = Sheets(vArray(rowNum))
If Err.Number <> 0 Then '--no such sheet, so add it
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = vArray(rowNum)
Set Ws = Sheets(vArray(rowNum))
End If
End IF
Next rownum
Ws.Activate
Ws.Range("A1").offset(rownum).value = rownum
End Sub