Is there any way to batch rename sheets in VBA:
Something like:
sheets(array(1, 2, 3)).name = array("hep", "hey", "heppa!")
naming sheets 1, 2, 3 as "hep", "hey" and "heppa!"
Clearly it doesn't work directly
And some experimentation with SelectedSheets didn't lead anywere
This is as close as I could get it, someone else may find a method to skip a loop
[Updated with the standard way I would do this below including error handling - I hadn't actually tried setting a collection of sheets like this before]
Normal Code
Sub Normal()
Dim strShtOld()
Dim strShtNew()
Dim sht As Worksheet
Dim lngSht As Long
strShtNew = Array("hep", "hey", "heppa!")
strShtOld = Array("Sheet1", "Sheeta2", "Sheet3")
On Error Resume Next
For lngSht = LBound(strShtOld) To UBound(strShtOld)
Set ws = Nothing
Set ws = Sheets(strShtOld(lngSht))
If Not ws Is Nothing Then ws.Name = strShtNew(lngSht)
Next lngSht
End Sub
Why the batch rename, curiousity or do do you have such a large amount of renaming to do that you are concerned with code runtime?
Array Effort
Sub ArrayEx()
Dim varShts
Dim varSht
Dim strArray()
strArray = Array("hep", "hey", "heppa!")
Set varShts = Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
For varSht = 1 To varShts.Count
varShts(varSht).Name = strArray(varSht - 1)
Next
End Sub
I have created a pair of macros:
Macro 1:
Sub Sheetlist()
Dim x As Integer
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "sheetlist"
Range("A1").Select
ActiveCell.FormulaR1C1 = "Sheet List"
Range("C1").Select
ActiveCell.FormulaR1C1 = "New List"
For x = 1 To Worksheets.Count
Cells(x + 1, 1).Value = Worksheets(x).Name
Next x
End Sub
This macro creates a sheet in your current workbook called "sheetlist" with the list of all sheets in your current workbook. This sheet also has a column titled "New List" (C1) which you can enter as many sheet names as you want to rename.
What you can do now is eliminate the names from column A1 which you want to exclude from the renaming process. Make sure that there are no blanks in columns A and C, and that the number of names in A and C match as well.
Now you are ready to run the 2nd Macro:
Sub batchrename()
'
' batchrename Macro
'
Dim OldSheetName As String
Dim NewSheetName As String
Dim SheetCount As Integer
Dim NewSheetList As String
NewSheetList = InputBox("How many names are there?") + 1
For SheetCount = 1 To Range("C2:C" & NewSheetList).Count
OldSheetName = Sheets("sheetlist").Cells(SheetCount + 1, 1)
NewSheetName = Sheets("sheetlist").Cells(SheetCount + 1, 3)
Sheets(OldSheetName).Select
ActiveSheet.Name = NewSheetName
Next SheetCount
End Sub
This macro will go to the names listed in sheetlist A and change them to the names listed in sheetlist C. The prompt will ask you where the list of names are, input the number of names you have in column C, and hit enter.
Enjoy
Related
I'm trying to create a tool in which I can select 2 files. In the first file (File1 in range B2) a few changes are made before looking up values in the second file (File2 in range B3) and paste them in the first file. I've created two buttons in the tool to select the files.
I want to a write code to lookup values in the second file but I'm getting different errors retrieving the information from the second second file. Can anyone help me with this?
I need to paste the values in the 8th row from the second file in the first file (same column) using the lookup value from the first column.
See code below: this is what I tried. Debugging needed in the vlookup subsection. Can anyone help me with this? Is there an easier way to lookup the values?
Sub Past_dues_button12345()
'Macro to create past due list daily
Dim wb1 As Excel.Workbook
Dim File As String
Dim File2 As String
File = Sheets("Tool").Range("B2")
File2 = Sheets("Tool").Range("B3")
Set wb1 = Workbooks.Open(File)
remove_repair
add_columns_with_comments
add_data_new_column
vlookup
pastevalues
Sharewb
End Sub
Sub add_columns_with_comments()
Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("Table1[[#Headers],[Column3]]").Select
ActiveCell.FormulaR1C1 = "PN"
Range("Table1[[#Headers],[Column2]]").Select
ActiveCell.FormulaR1C1 = "MRPc"
Range("Table1[[#Headers],[Column1]]").Select
ActiveCell.FormulaR1C1 = "Comment"
End Sub
Sub vlookup()
Dim rw As Long, x As Range
Dim extwbk As Workbook, twb As Workbook
Set twb = ThisWorkbook
Workbooks("Tool_SO.XLSM").Activate
File2 = Sheets("Tool").Range("B3")
Set extwbk = Workbooks.Open(File2)
Set x = extwbk.Worksheets("Material Availability").Range("A1:H1000")
With twb.Sheets("Material Availability")
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(rw, 2) = Application.vlookup(.Cells(rw, 1).Value2, x, 8, False)
Next rw
End With
extwbk.Close savechanges:=False
End Sub
When using multiple workbooks, I avoid any usage of Applicationlevel functions, where possible, and try to remove any aspect of going back and fourth between workbooks.
As such, arrays will be your friend.
Here is the very simple model I have constructed, in Book1:
Based on said model, I am hoping to Match with Column 1 and Index with Column 2, within Book2 (ThisWorkbook).
There will be several items to dimension, including end rows/columns, the above array, the input terms, the output cells... but a good set-up carries the weight.
I will set this up in a single sub-routine for a single cell search term and output cell, noting that InputBoxes for workbook names, functions, etc., would make this more robust... the goal of my post is to give an example.
Here is the code I would generate to match within the above array (searchArray in my code), using a single cell for input/output:
Sub IndexFromExternalSearchSheetViaArray()
'Using External Workbook
Dim searchSheet As Worksheet
Set searchSheet = Workbooks("Book1").Worksheets(1)
With searchSheet
Dim searchSheetEndColumn As Long
searchSheetEndColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
Dim searchSheetEndRow As Long
searchSheetEndRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim searchArray As Variant
searchArray = .Range(.Cells(1, 1), .Cells(searchSheetEndRow, searchSheetEndColumn)).Value
End With
'Using This Workbook
Dim outputSheet As Worksheet
Set outputSheet = ThisWorkbook.Worksheets(1)
Dim searchTerm As Range
Set searchTerm = outputSheet.Cells(1, 1)
Dim outputCell As Range
Set outputCell = outputSheet.Cells(1, 2)
'Matching/Indexing with Array
Dim iterator As Long
For iterator = 1 To searchSheetEndRow Step 1
If searchTerm.Value = searchArray(iterator, 1) Then
Dim outputValue As String
outputValue = searchArray(iterator, 2)
Exit For
Else
If iterator = searchSheetEndRow Then outputValue = "No match found"
End If
Next iterator
'Final Output
outputCell.Value = outputValue
End Sub
With a single input, after running the code, I may have:
or:
I know this topic has been asked about before but nothing quite covers what I need. So here's the thing..
I have two workbooks. One is exported from another program which shows a staff member's Surname, first name, email and which ward they work on.
[Workbook1 example]
The second is the full staff list which has the same details but also a check list column.
[Workbook2 example]
What I need is a macro (probably a vlookup) which takes the information from the workbook1, checks against surname, first name and ward on workbook2 to ensure that it is the correct member of staff, copies the email onto workbook 2 and also fills the checklist column on workbook 2 to "Yes".
I'm afraid I am at a loss as to how to incorporate all of this together. Please help.
This is what I have so far but my knowledge is limited and did not know how to proceed.
Private Sub UpdateTraining_Click()
Dim I As Integer
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Wb As Workbook
Dim CopyData As String
Dim RwCnt As Long
Dim RwCnt2 As Long
Dim Rw As Long
Dim Clm As Long
Dim SName As String
Dim FName As String
Dim Wrd As String
Dim vArr
Dim ClmLet As String
Set Ws1 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Staff Training Record")
Set Ws2 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Do Not Use")
Workbooks.Open ("C:\TypeformNursingDocumentation.xlsx")
Set Ws3 = Workbooks("TypeformNursingDocumentation.xlsx").Worksheets("tWeXNp")
RwCnt = Ws3.Cells(Rows.Count, 1).End(xlUp).Row
RwCnt2 = Ws1.Cells(Rows.Count, 1).End(xlUp).Row
Rw = Ws3.Range("F2").Row
Clm = Ws3.Range("F2").Column
Table1 = Ws3.Range("F2:F" & RwCnt)
vArr = Split(Cells(1, Clm).Address(True, False), "$")
ClmLet = vArr(0)
For Each cl In Table1
Ws3.Range(ClmLet & Rw).Select
SName = ActiveCell.Value
FName = ActiveCell.Offset(0, -1).Value
Wrd = ActiveCell.Offset(0, -4).Value
Rw = Rw + 1
Next cl
End Sub
You can achieve this with formulas but then you have to open Workbook1 for the formulas to work in Workbook2. So below approach uses VBA to achieve the results
Copy the below UDF in a module in Workbook2:
Sub UpdateMyList()
Dim oSourceWB As Workbook
Dim oSourceR As Variant
Dim iTotSRows&, iTotCRows&, iCC&, iSC&
Dim oCurR As Variant
Application.ScreenUpdating = False
' First lets get source data
Set oSourceWB = Workbooks.Open("C:\Temp\EmpLookup.xlsx", ReadOnly:=True) ' Change the source file name
With oSourceWB.Worksheets("Sheet1") ' Change the source sheet name
iTotSRows = .Range("A" & .Rows.count).End(xlUp).Row
oSourceR = .Range("A2:G" & iTotSRows)
End With
oSourceWB.Close False
' We now need the data from the sheet in this workbook to compare against
With ThisWorkbook.Worksheets("Sheet8") ' Change the sheet name to the sheet in your workbook
iTotCRows = .Range("A" & .Rows.count).End(xlUp).Row
oCurR = .Range("A2:H" & iTotCRows)
End With
' Next, lets compare and update fields
For iCC = 1 To UBound(oCurR)
For iSC = 1 To UBound(oSourceR)
If (oCurR(iCC, 1) = oSourceR(iSC, 6)) And (oCurR(iCC, 2) = oSourceR(iSC, 5)) And (oCurR(iCC, 5) = oSourceR(iSC, 2)) Then
oCurR(iCC, 7) = oSourceR(iSC, 7)
oCurR(iCC, 8) = "Yes"
Exit For
End If
Next
Next
Application.ScreenUpdating = True
' Finally, lets update the sheet
ThisWorkbook.Worksheets("Sheet8").Range("A2:H" & iTotCRows) = oCurR
End Sub
I've commented on the lines where you need to change references to workbook or worksheets. As long as you have updated the workbook and worksheet references, this should give you the desired results
I built the above UDF based on the columns as you provided in your question. If the columns change, you will have to modify the UDF or get the columns dynamically
You can use and If(Countif()) style function, where the countif checks for the presence of your value, and the if will return true if it is a match, then you can use the if true / false values accordingly. Let me know if you need more details but it could look something like this =IF(COUNTIF(The selected cell is in the selected range),"Yes", "No"). Then record this as a macro and copy the code into yours.
Context: New to VBA
Task: I have a contact list in Worksheet1 which contains columns: LastName, FirstName, email, phone #, and several more. I have a second contact list in Worksheet2 (formatted exactly the same) which contains approximately 500 of the 1,000 names found in the Worksheet1 contact list BUT with updated contact information (email, phone #, etc.). I'm trying to write code to find which names are in both worksheets, and for those names, copy the email, phone#, etc. from Worksheet2 (updated information) and paste it into the corresponding location in Worksheet2.
Code: This is what I have so far. It does not work.
Sub UpdateContacts()
Dim Reference As String
Dim Range As Range
Dim ContactList As Worksheet
Dim UpdatedContacts As Worksheet
ContactList = ActiveWorkbook.Sheets("Contact List")
UpdatedContacts = ActiveWorkbook.Sheets("Updated Contacts")
Reference = ContactList.Range("B5", "C5").Value
j = 5
For i = 5 To UpdatedContacts.Cells(Rows.Count, 1).End(xlUp).Row
If UpdatedContacts.Range(Cells(i, 2), Cells(i, 3)).Value = Reference Then
UpdatedContacts.Range(Cells(i, 4), Cells(i, 17)).Copy _
Destination:=ContactList.Range(Cells(j, 4), Cells(j, 17))
j = j + 1
End If
Next i
End Sub
Any help is greatly appreciated!
Thanks
Here is a working solution with some minor improvements such as Option Explicit, fully qualified references at all times, Option Compare Text to ignore capital letters when comparing the names, Trim to ignore possible leading or trailing spaces, and creating another outer loop to do the comparison for all names on shtContactList:
Option Explicit
Option Compare Text
Sub UpdateContacts()
Dim ws As Worksheet
Dim rngCell As Range
Dim i As Long, j As Long
Dim strReference As String
Dim shtContactList As Worksheet
Dim shtUpdatedContacts As Worksheet
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Contact List"
Set shtContactList = ws
Case "Updated Contacts"
Set shtUpdatedContacts = ws
Case Else
Debug.Print ws.Name
End Select
Next ws
If shtContactList Is Nothing Or shtUpdatedContacts Is Nothing Then
MsgBox "One or more required sheet(s) were not found." & Chr(10) & "Aborting..."
Exit Sub
End If
For j = 5 To shtContactList.Cells(shtContactList.Rows.Count, "A").End(xlUp).Row
strReference = Trim(shtContactList.Cells(j, 2).Value2) & ", " & Trim(shtContactList.Cells(j, 3).Value2)
For i = 5 To shtUpdatedContacts.Cells(shtUpdatedContacts.Rows.Count, 1).End(xlUp).Row
If Trim(shtUpdatedContacts.Cells(i, 2).Value2) & ", " & Trim(shtUpdatedContacts.Cells(i, 3).Value2) = strReference Then
shtUpdatedContacts.Range(shtUpdatedContacts.Cells(i, 4), shtUpdatedContacts.Cells(i, 17)).Copy _
Destination:=shtContactList.Range(shtContactList.Cells(j, 4), shtContactList.Cells(j, 17))
j = j + 1
End If
Next i
Next j
End Sub
If the code is running slow you might want to consider using an array: (1) put the entire sheet shtUpdatedContacts into an array as well as the sheet shtContactList and (2) then make the search / comparison there. (3) Finally, paste the updates array back to sheet shtContactList.
I am hoping someone can assist me with a sheet array issue I am having. For background information, the main "template" sheet is copied multiple times as a new input is stored in each version. The newly created sheet is named after the input. The inputs are almost random, so defining by sheetname is not an option.
Once the workbook has all of the new sheets added I am trying to isolate a subset of the sheets. The problem I run into is the sheet numbers (as seen in the project window) don't necessary go in order. Also many sheets are hidden.
The following code is portion being used to create the sheet array, which breaks upon trying to save the array as a variable (objsheets).
Not sure what I am missing to have this array saved. Any help would be greatly appreciated. Code Below.
Thanks,
JM
At this point the workbook has the "template" sheet copied and has 50 new sheets added (hypothetical number).
Sub SheetArrayTest
Dim mySheet As Object
Dim objShts As Excel.Sheets
Dim varArray As Variant
Dim FirstSheetNum As Long
Dim FirstSheet As String
Dim LastSheetNum As Long
Dim LastSheet As String
'Selects template sheet
Sheets("Template").Select
'Selects the first sheet following the template sheet, and is the desired start of the array
Sheets(ActiveSheet.Index + 1).Activate
'Creates variables for starting point
FirstSheet = ActiveSheet.Name
FirstSheetNum = ActiveSheet.Index
'Loops through each sheet in the workbook following the "FirstSheet" and selects it to create the array
For Each mySheet In Sheets
With mySheet
If .Visible = True And mySheet.Index >= FirstSheetNum Then .Select Replace:=False
End With
LastSheetNum = mySheet.Index
LastSheet = Sheets(LastSheetNum).Name
If FirstSheetNum < LastSheetNum Then
'Attempt at preserving the array
ReDim varArray(FirstSheetNum To LastSheetNum)
varArray(LastSheetNum) = LastSheet
End If
Next mySheet
'ERROR
Set objShts = Sheets(varArry)
...
End Sub
You can't use the Set keyword to assign to an array. That's your first problem, and would explain an error on that line.
Set objSheets = Sheets(varArray)
That line may also fail because the Sheets takes an index value, not an array of values.
You're also not preserving the array with ReDim Preserve to extend it.
In any case... let's see if we can't figure it out. it sounds like you're trying to store an array of Sheet/Worksheet Objects. But your code is assigning a string value to your array (LastSheet), rather than an object.
Instead of storing the sheet name (LastSheet) in the array, store the sheet itself (unless you really need the index value).
You can maybe modify this:
Dim numberOfSheets as Integer
numberOfSheets = -1
For Each mySheet In Sheets
With mySheet
If .Visible = True And mySheet.Index >= FirstSheetNum Then .Select Replace:=False
End With
LastSheetNum = mySheet.Index
LastSheet = Sheets(LastSheetNum).Name
If FirstSheetNum < LastSheetNum Then
'increase the size of the array
numberOfSheets = numberOfSheets + 1
ReDim Preserve varArray(numberOfSheets)
Set varArray(numberOfSheets) = Sheets(LastSheet)
End If
Next mySheet
You do not need the variable objSheets at all.
Sub M_snb()
For Each sh In Sheets
If sh.Visible = -1 And sh.Name <> "template" Then c00 = c00 & "|" & sh.Name
Next
Sheets(Split(Mid(c00, 2), "|")).Select
End Sub
Sub M_snb()
For Each sh In Sheets
If sh.Visible = -1 And sh.Name <> "template" Then c00 = c00 & "|" & sh.Name
Next
Sheets(Split(Mid(c00, 2), "|")).Select
End Sub
courtesy of snb
I am trying to make a vba program that will take the stock ticker in column A and paste it on a different "settings" sheet in a cell, then the program will execute two other vba codes that download historical data and backtest my formula. Then the program will return to the "data" sheet and print the value in "B10" on "settings" into column D in "data". I need the printed value to be in column d corresponding to the ticker's row. The program has to repeat 500 times. Can you help me find how to do this or point out what is wrong in my code? Thanks!
Sub finalbalance()
Dim ticker As Range
Dim i As Long
Sheets("results").Activate
Set ticker = ActiveCell
For i = 1 To 500
Sheets("results").Activate
ticker.Select
Selection.Copy
Sheets("Settings").Select
Range("B1").Select
ActiveSheet.Paste
Application.Run "datadownload"
Application.Run "btest"
ticker.Offset(0, 3) = Sheets("settings").Range("B10")
ticker.Address = ticker.Offset(1, 0)
Next i
End Sub
The problem is you can't assign a value to the .Address property:
'Instead of
ticker.Address = ticker.Offset(1, 0)
'Use:
Set ticker = ticker.offset(1, 0)
And that will get your code working as is. However, the select statements really aren't necessary and should be avoided. Here's a cleaned up version of the code:
Sub finalbalance()
Dim wsResults As Worksheet
Dim wsSettings As Worksheet
Dim rngStartCell As Range
Dim arrResults() As Variant
Dim lNumReps As Long
Dim i As Long
Set wsResults = Sheets("Results")
Set wsSettings = Sheets("Settings")
Set rngStartCell = wsResults.Range("A2")
lNumReps = 500
ReDim arrResults(1 To lNumReps)
For i = 1 To lNumReps
wsSettings.Range("B1").Value = rngStartCell.Offset(i - 1).Value
Application.Run "datadownload"
Application.Run "btest"
arrResults(i) = wsSettings.Range("B10").Value
Next i
rngStartCell.Offset(, 3).Resize(lNumReps).Value = Application.Transpose(arrResults)
End Sub