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
Related
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.
I'm trying to loop through several worksheets that contain some source data that has to be copied to one main sheet, called "PriorityList" here.
First of all, the sub is not working and I think the error is somewhere in the "find"-method. Second, the sub takes quite long to run, and I think this is maybe because the "find"-method searches through the whole sheet instead of only the relevant range?
Thank you very much for your answers!
Patrick
Sub PriorityCheck()
'Sub module to actualise the PriorityList
Dim CurrWS As Long, StartWS As Long, EndWS As Long, ScheduleWS As Long
StartWS = Sheets("H_HS").Index
EndWS = Sheets("E_2").Index
Dim SourceCell As Range, Destcell As Range
For CurrWS = StartWS To EndWS
For Each SourceCell In Worksheets(CurrWS).Range("G4:G73")
On Error Resume Next
'Use of the find method
Set Destcell = Worksheets(CurrWS).Cells.Find(What:=SourceCell.Value, After:=Worksheets("PriorityList").Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
'Copying relevant data from source sheet to main sheet
If Destcell <> Nothing Then
Destcell.Offset(0, 2).Value = SourceCell.Offset(0, 5).Value + Destcell.Offset(0, 2).Value
If SourceCell.Offset(0, 3).Value = "x" Then Destcell.Offset(0, 3).Value = "x"
End If
End If
On Error GoTo 0
Next SourceCell
Next CurrWS
End Sub
here short sample how to use 'Find' method to find the first occurrence of the source.Value in the priorityList.
Source cell is one of the cells from the range "G4:G73" and priorityList is used range on "PriorityList" sheet. Hope this helps.
Public Sub PriorityCheck()
Dim source As Range
Dim priorityList As Range
Dim result As Range
Set priorityList = Worksheets("PriorityList").UsedRange
Dim i As Long
For i = Worksheets("H_HS").Index To Worksheets("E_2").Index
For Each source In Worksheets(i).Range("G4:G73")
Set result = priorityList.Find(What:=source.Value)
If (Not result Is Nothing) Then
' do stuff with result here ...
Debug.Print result.Worksheet.Name & ", " & result.Address
End If
Next source
Next i
End Sub
Here is an approach using arrays. You save each range into an array, then iterate through array to satisfy your if-else condition. BTW IF you want to find the exact line with code error, then you must comment On Error Resume Next line.. :) Further, you can simply store the values into a new array, dump everything else into the main sheet later after iterating through all the sheets instead of going back and forth to sheets, code, sheets..code..
Dim sourceArray as Variant, priorityArray as Variant
'-- specify the correct priority List range here
'-- if multi-column then use following method
priorityArray = Worksheets(CurrWS).Range("A1:B10").Value
'-- if single column use this method
' priorityArray = WorkSheetFunction.Transpose(Worksheets(CurrWS).Range("A1:A10").Value)
For CurrWS = StartWS To EndWS
On Error Resume Next
sourceArray = Worksheets(CurrWS).Range("G4:J73").Value
For i = Lbound(sourceArray,1) to UBound(sourceArray,1)
For j = Lbound(priorityArray,1) to UBound(priorityArray,1)
If Not IsEmpty(vArr(i,1)) Then '-- use first column
'-- do your validations here..
'-- offset(0,3) refers to J column from G column, that means
'---- sourceArray(i,3)...
'-- you can either choose to update priority List sheet here or
'---- you may copy data into a new array which is same size as priorityArray
'------ as you deem..
End If
Next j
Next i
Next CurrWS
PS: Not front of a MS Excel installed machine to try this out. So treat above as a code un-tested. For the same reason I couldn't run your find method. But it seems odd. Don't forget when using match or find it's important to do proper error handling. Try checking out [find based solutions provided here.
VBA in find function runtime error 91
Excel 2007 VBA find function. Trying to find data between two sheets and put it in a third sheet
I have edited the initial code to include the main logic using two array. Since you need to refer to values in J column of source sheets, you will need to adjust source array into a two-dimensional array. So you can do the validations using first column and then retrieve data as you desire.
For everyone maybe interested, this is the code version that I finally used (pretty similar to the version suggested by Daniel Dusek):
Sub PriorityCheck()
Dim Source As Range
Dim PriorityList As Range
Dim Dest As Range
Set PriorityList = Worksheets("PriorityList").UsedRange
Dim i As Long
For i = Worksheets("H_HS").Index To Worksheets("S_14").Index
For Each Source In Worksheets(i).Range("G4:G73")
If Source <> "" Then
Set Dest = PriorityList.Find(What:=Source.Value)
If Not Dest Is Nothing Then
If Dest <> "" Then
Dest.Offset(0, 2).ClearContents
Dest.Offset(0, 2).Value = Source.Offset(0, 5).Value + Dest.Offset(0, 2).Value
End If
If Source.Offset(0, 3).Value = "x" Then Dest.Offset(0, 3).Value = "x"
Debug.Print Dest.Worksheet.Name & ", " & Dest.Address
End If
End If
Next Source
Next i
MsgBox "Update Priority List completed!"
End Sub
I want to enter multiple values in a single cell in excel sheet based on the certain condition as in if there are multiple sheets in the workbook then if any of the sheet starting with name TC contains color in it then I've to enter the information in Read Me Section of the Excel Workbook a another worksheet. The problem with my code is that its not displaying unique sheets which contain coloring...Suppose Sheet "TC_1" and "TC_3" contains color in any of the cell then its displaying the output as ";TC_3;TC_3;TC_3;" although the expected output over here is "TC_1;TC_3".
Here, is the code:
Sub ErrorInSheet()
Dim Row
Dim Names As String
Names = ""
For Row = 2 To tsheet.UsedRange.Rows.Count
For Chkcol = 1 To tsheet.UsedRange.Columns.Count
If tsheet.Cells(Row, Chkcol).Interior.ColorIndex = 3 Then
Names = Names & ";" & tsheet.Name
End If
Next
Next Row
Sheets("Read Me").Cells(13, 5).Value = Names
End Sub
Sub iterateSheets()
For Each sheet1t In Worksheets
If InStr(1, sheet1t.Name, "TC") Then
Set tsheet = sheet1t
Call ErrorInSheet
End If
Next
End Sub
I think this will work for you - I tested it and worked for me.
Sub FindErrors()
Dim sht As Worksheet, cl As Range, shtNames As String
shtNames = vbNullString
For Each sht In Worksheets
If Left$(sht.Name, 2) = "TC" Then
For Each cl In sht.UsedRange.Cells
If cl.Interior.ColorIndex = 3 Then
shtNames = IIf(shtNames = vbNullString, sht.Name, shtNames & ";" & sht.Name)
End If
Next cl
End If
Next sht
Worksheets("Read Me").Cells(13, 5) = shtNames
End Sub
Notes:
I've explicitly declared the variables
I am assuming all your sheets start with "TC" so I've used Left$ but you can use InStr if you like
I've used the ternary IIF statement to stop you getting a leading ;
I've put all the code in one Sub but you can split it out if you like
In Excel I have a column of words. I believe you call words "strings" in the programming world.
Row by row, I need to take each word in the column and put single inverted commas around it.
For example, if the word in the cell is dog, I need to change it to 'dog'.
I am trying to write a macro to do this, but I am already running into problems with the very first part of the vba code, which is just to import the column of words into vba from the excel spreadsheet.
My code is below. The Error message says "subscript out of range", but as you can see I have dimmed the array. What am I doing wrong? Thanks.
Sub putquotes()
Dim sym(1 To 162) As String
For i = 1 To 162
sym(i) = Worksheets("sheet1").Cells(i + 1, 1)
Next i
End Sub
I think your issue is your sheet1 name which should probably be Sheet1
I would use something like this which will run on the first worksheet (see Set ws = Sheets(1))
Note that the third sheet would be Set ws = Sheets(3), or you could use Set ws = Sheets("Sheet1") if you did have such a sheet
This code:
will run independent of the sheet that is selected
looks from the first to last used cell in column A (rather than hard-coding 162 rows)
uses variant arrays rather than ranges for speed
adds a double '' to ensure the first is visible :)
Sub PutQuotes()
Dim ws As Worksheet
Dim varList
Dim rng1 As Range
Dim lngCnt As Long
Set ws = Sheets(1)
Set rng1 = ws.Range(ws.[a1], ws.Cells(Rows.Count, "A").End(xlUp))
varList = rng1.Value2
For lngCnt = 1 To UBound(varList)
If Len(varList(lngCnt, 1)) > 0 Then _
varList(lngCnt, 1) = "''" & varList(lngCnt, 1) & "'"
Next
'dump updated array back over range
rng1.Value2 = varList
End Sub
You don't have a sheet named "Sheet1". Either:
This code lives in a standard module in the workbook with the data and you've renamed the
sheet, or
The code lives in another workbook and you haven't properly qualified your Worksheets property
I'm going to assume the latter. When you use collection properties like Worksheets or Cells, Excel makes assumptions on who the parent is. An unqualified Worksheets call in a standard module will assume
ActiveWorkbook.Worksheets()
An unqualified Worksheets call in the ThisWorkbook module will assume
ThisWorkbook.Worksheets()
To check where the problem is, add this line to your code
Debug.Print Worksheets("Sheet1").Parent.Name
That will tell you which workbook Excel is using and may be different than you want.
To avoid bad guessing, it's best to fully qualify your references. For instance, if you're opening the workbook with the data, it might look like this
Sub putquotes()
Dim wb As Workbook
Dim sym(1 To 162) As String
Dim i As Long
Set wb = Workbooks.Open("Path\Name")
For i = 1 To 162
sym(i) = wb.Sheets("Sheet1").Cells(i + 1, 1)
Next i
End Sub
Holding that wb reference is an easy way to qualify the reference. If you're not opening a separate file in code, you can just qualify explicitly like
ThisWorkbook.Worksheets("Sheet1")
ActiveWorkbook.Worksheets("Sheet1")
Workbooks("Mybook.xlsx").Worksheets("Sheet1")
A better way to read cell values into an array is like this
Sub putquotes()
Dim wb As Workbook
Dim sym As Variant
Dim i As Long
Set wb = Workbooks.Open("Path\Name")
sym = wb.Sheets("Sheet1").Range("A2").Resize(162, 1).Value
For i = LBound(sym, 1) To UBound(sym, 1)
Debug.Print "'" & sym(i, 1) & "'"
Next i
End Sub
That will give you a two-dimensional-base-1 array, which you may not like, but it's faster than reading them in one at a time.
I believe you want something like this...
Public Sub DoQuotes()
Dim iRow As Integer
Dim Result() As String
iRow = 1
Do While Not IsEmpty(Sheet1.Cells(iRow, 1))
ReDim Preserve Result(iRow - 1)
Result(iRow - 1) = "'" & Sheet1.Cells(iRow, 1) & "'"
iRow = iRow + 1
Loop
For Each x In Result
MsgBox (x)
Next x
End Sub
However, bear in mind that Excel will treat the first quote as a text delimiter so it whilst the value in the array is 'something' it will look like something' in Excel.
Just a general aside point, try to avoid calls to Worksheets() instead use the strongly typed Sheet1 object - saves all sorts of future pain if the worksheets get renamed. You can see what the sheets are "really" called in the vba editor. It will say something like Sheet1(MyWorksheet)
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