I have several VBA routines in an Excel 2007. There is a template worksheet which gets copied (and accordingly altered) up to 50 times. Now, this template contains a range called "HideRows", so this range gets copied several times in all those new worksheets. I want to hide all rows that contain the value 0 in the range "HideRows". Not all rows shall be hidden, only those rows that contain the value 0. This is what I've got so far:
Option Explicit
Sub HideEmptyRows()
Dim rngName As Range
Dim cell As Range
Application.ScreenUpdating = False
For Each rngName In ActiveWorkbook.Names
If rngName.Name = "HideRows" Then
With cell
For Each cell In rngName
If .Value = 0 Then
.EntireRow.Hidden = True
End If
Next cell
End With
End If
Next rngName
What's wrong here and what do I need to do to get it to work?
You can address the named range directly without looping. There is no test that this named range exists, as per your description it is safe to assume so.
Secondly, do not use the "with" statement outside of the loop that sets the referenced variable. Try this instead:
Option Explicit
Sub HideEmptyRows()
Dim rngName As Range
Dim cell As Range
Application.ScreenUpdating = False
For Each cell In range("HideRows")
If cell.Value = 0 Then
cell.EntireRow.Hidden = True
End If
Next cell
Application.ScreenUpdating = True
edit:
If the workbook contains multiple identical sheets where each sheet may contain this named range you will have to loop. This code will not loop over all names but over all sheets, and test for existance of the named range in each sheet:
Sub HideEmptyRows()
Dim sh As Sheets
Dim rng As Range, cell As Range
For Each sh In ActiveWorkbook.Sheets
Set rng = Nothing ' this is crucial!
On Error Resume Next
Set rng = sh.Names("HideRows")
On Error GoTo 0
If Not rng Is Nothing Then
For Each cell In rng
cell.EntireRow.Hidden = (cell.Value = 0)
Next cell
End If
Next sh
End Sub
The range variable has to be reset explicitly before the assignment as this step is skipped if the range does not exist. The following If would use the value last assigned then, which would be wrong.
Related
I got some script here to open up multiple workbooks with a worksheet and then copy it to a worksheet as a loop, but I need an additional cell (the date) from another worksheet in the multiple workbooks because the output I got cannot be changed and just added to the same sheet.
What I need is for this code to include a single cell range from another sheet on the workbook and then fill it to the bottom of the range per workbook.
I cant use UNION as it's not the same length, and I looked up merging ranges into one, but I get type mismatch errors.
VBA: How to combine two ranges on different sheets into one, to loop through I tried this but I can't figure out how to put it into my code.
Here is the code I have that works so far for just the one range. The rngdate copies over but does not leave a gap or autofill to the next loop, it just pastes under each other, so maybe this code will work but I'm missing something basic like autofill?
Dim vFileNames As Variant
Dim y As Long
Dim wbTemp As Workbook
Dim wbNew As Workbook
Dim blHeader As Boolean
Dim Rng As Range
Dim rngDate As Range
Application.ScreenUpdating = False
Set wbNew = Workbooks("master_timesheet") '.Add
blHeader = False
vFileNames = Application.GetOpenFilename(Title:="Select all workbooks to copy", _
MultiSelect:=True)
'Will not be array if no file is selected
'If user selects one or more files, files will be stored as an array
If Not IsArray(vFileNames) Then GoTo ConsolidateWB_End
For y = LBound(vFileNames) To UBound(vFileNames)
'Open each wb selected
Set wbTemp = Workbooks.Open(vFileNames(y))
Set rngDate = wbTemp.Worksheets("Communications Unlimited Inc").Range("A5").CurrentRegion
Set Rng = wbTemp.Worksheets("Export").Range("A1").CurrentRegion
'If header row already copied, then offset by 1 to exclude header
If blHeader Then
Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)
'If header row not already copied, keep rng as is and change blHeader to true
Else
blHeader = True
End If
'Paste to next row on new wb
Rng.Copy Destination:=wbNew.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
rngDate.Copy Destination:=wbNew.Sheets(1).Range("P65536").End(xlUp).Offset(1, 0)
wbTemp.Close SaveChanges:=False
Next y
ConsolidateWB_End:
Application.ScreenUpdating = True
End Sub
If I read your problem correctly you want the date, rngdate, pasted adjacent to each and every line of data you have just copied. However your current code only puts the data on the first row. Below is an adaptation of how I have solved this problem myself, taking account of your existing code. (My guess is that there is a much more elegant solution than this which I'm just not aware.)
Dim pasterangefirstrow As Integer
...
pasterangefirstrow = wbNew.Sheets(1).Range("D65536").End(xlUp).Offset(1, 0).Row
...
With wbNewSheets(1)
Rng.Copy Destination:=.Range("D65536").End(xlUp).Offset(1, 0)
rngdate.Copy Destination:=.Range("P" & pasterangefirstrow & ":P" & pasterangefirstrow + Rng.Rows.Count - 1)
End With
---Update---
Thanks for the responses, I have found that DragonSamu's updated answer works perfectly.
---Original Post---
I have been trying to figure out where I am going wrong for the past few hours but I can't spot it. I think it's because the script is trying to draw the value from the active worksheet which is not what I want. Hopefully somebody can put me on the rite track - I think the answer should be relatively obvious but I just can't see it!
Basically, I am trying to populate a Combobox with a dynamic range of values that exist in another worksheet (but in the same workbook). I can get the Combobox to populate when I run the script in the worksheet 'Materials' (which is where the dynamic list is drawn from) but not when I run it in the worksheet 'Products'.
Unfortunately the script is designed to populate Products with Materials so is be run in a UserForm when the 'Products' worksheet is open and the 'Materials' worksheet would therefore be inactive.
I should also note that this script has been adapted from code I found elsewhere on this forum, so if it seems familiar I thank you in advance :)
Private Sub UserForm_Initialize()
Dim rRange As Range
On Error GoTo ErrorHandle
'We set our range = the cell B7 in Materials
Set rRange = Worksheets("Materials").Range("B7")
'Check if the cell is empty
If Len(rRange.Formula) = 0 Then
MsgBox "The list is empty"
GoTo BeforeExit
End If
'Finds the next empty row and expands rRange
If Len(rRange.Offset(1, 0).Formula) > 0 Then
Set rRange = Range(rRange, rRange.End(xlDown))
End If
'The range's address is our rowsource
Mat1_Name_ComBox.RowSource = rRange.Address
Mat2_Name_ComBox.RowSource = rRange.Address
Mat3_Name_ComBox.RowSource = rRange.Address
Mat4_Name_ComBox.RowSource = rRange.Address
Mat5_Name_ComBox.RowSource = rRange.Address
BeforeExit:
Set rRange = Nothing
Exit Sub
ErrorHandle:
MsgBox Err.Description
Resume BeforeExit
End Sub
Any help is much appreciated.
Cheers,
Simon
From what I can see your code would be giving an error here:
If Len(rRange.Offset(1, 0).Formula) > 0 Then
Set rRange = Range(rRange, rRange.End(xlDown))
End If
Because your trying to set rRange by using Range() without defining the Worksheet first. This will get the Range from the ActiveWorksheet.
change it to the following:
If Len(rRange.Offset(1, 0).Formula) > 0 Then
Set rRange = Worksheets("Materials").Range(rRange, rRange.End(xlDown))
End If
best practice would be the following:
Private Sub UserForm_Initialize()
Dim wb as Workbook
Dim sh as Worksheet
Dim rRange As Range
On Error GoTo ErrorHandle
'Set the Workbook and Worksheet
set wb = Workbooks("products.xlsx")
set sh = wb.Worksheets("Materials")
'We set our range = the cell B7 in Materials
Set rRange = sh.Range("B7")
'Check if the cell is empty
If Len(rRange.Formula) = 0 Then
MsgBox "The list is empty"
GoTo BeforeExit
End If
'Finds the next empty row and expands rRange
If Len(rRange.Offset(1, 0).Formula) > 0 Then
Set rRange = sh.Range(rRange, rRange.End(xlDown))
End If
By properly defining and setting your Workbook and Worksheet you correctly reference to them and don't get errors.
Update:
the 2nd problem is that rRange.Address only places the Range location inside your .RowSource not the Sheet it needs to look at.
change:
Mat1_Name_ComBox.RowSource = rRange.Address
to:
dim strSheet as String
strSheet = "Materials"
Mat1_Name_ComBox.RowSource = strSheet + "!" + rRange.Address
This way it will include the Sheet name into the .RowSource
I've created a small code to remove a range of cells from 2 separate worksheets and Worksheets that are starting with letter N, but always my code is giving me errors or Excel is crashing. The first and second line of code with ClearContents method is giving me those errors.
My code:
'clearing ranges
ThisWorkbook.Worksheets("Sheet1").range("A4", range("AY4").End(xlDown)).ClearContents
ThisWorkbook.Worksheets("Sheet2").range("A3", range("AK3").End(xlDown)).ClearContents
'deleting sheets
For Each sh In ThisWorkbook.Worksheets
If Left(sh.Name, 1) = "N" Then
ThisWorkbook.Worksheets(sh.Name).Delete
End If
Next sh
Thanks for the help!
edit to add some code for the ClearContents issue
ClearContents issue
you wrote
I want to delete the range from A4 until the right down corner of AY4
now it's up to what is to be intended as the "right down corner of AY4"
should it be the last non empty value on column AY then use:
With ThisWorkbook.Worksheets("Sheet001")
.Range("A4", .Cells(.Rows.Count, "AY").End(xlUp)).ClearContents
End With
you may need some more code to handle the case the first non empty cell in column "AY" is above row 4
Sheet Deletion
you may want to try the "Array" approach to exploit an array flavour of the Item property of Worksheets collection and have a one-shot sheets deletion:
Option Explicit
Sub ws()
Dim sh As Worksheet
Dim shtsToDelete As String
With ThisWorkbook
For Each sh In .Worksheets
If Left(sh.name, 1) = "N" Then shtsToDelete = shtsToDelete & sh.name & "\" '<-_| store sht names in a string delimiting them with an invalid character for sheet names
Next sh
If shtsToDelete <> "" Then '<--| if any sheet to be deleted has been found
Application.DisplayAlerts = False '<--| disable alerts to prevent popping out of msgbox prompting you to confirm sheets deletion
.Worksheets(Split(Left(shtsToDelete, Len(shtsToDelete) - 1), "\")).Delete '<--| delete list-sheets in one shot
Application.DisplayAlerts = True '<--| enable alerts back
End If
End With
End Sub
The error appears because you are not allowed to delete objects inside of the current for each loop. Try using a for loop, like this:
For i = ThisWorkbook.Worksheets.Count to 1 Step -1
If Left(ThisWorkbook.Worksheets(i).name, 1) = "N" Then
ThisWorkbook.Worksheets(i).Delete
End If
Next i
your Range definition is wrong, in the inner Range method call, you don't access the range of a specific sheet, so it uses Range of the default sheet. Second problem: If you delete something in a collection, you should loop backwards over the collection because otherwise the Delete operation leads index changes during the loop.
Dim wsheet1 As Worksheet
Dim wsheet2 As Worksheet
Set wsheet1 = ThisWorkbook.Worksheets("Sheet1")
Set wsheet2 = ThisWorkbook.Worksheets("Sheet2")
wsheet1.Columns("A:AY").ClearContents
wsheet2.Columns("A:AK").ClearContents
For i = ThisWorkbook.Worksheets.Count To 1 Step -1
If Left(ThisWorkbook.Worksheets(i).Name, 1) = "N" Then
ThisWorkbook.Worksheets(i).Delete
End If
Next i
I have one Workbook with multiple projects. Each project has it's own sheet. In each of these sheets there are columns for order numbers ("OrderNub").
In another sheet called "MasterList" contains all of the order numbers across all project. This list is in column A.
I need a function or Macro that will search all of my sheets (bar MasterList) and will display the sheet name in column B.
Below is what I have in Excel:
Option Explicit
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
For Each ws In Worksheets
If ws.CodeName <> "MasterList" Then
Set rng = Nothing
On Error Resume Next
FindMyOrderNumber = ws.Name
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Range("A1").Value
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
Option Explicit
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
For Each ws In Worksheets
If ws.CodeName <> "MasterList" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Columns(1).Find(strOrder)
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Name
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
Assumptions:
Your project sheets us Table objects. If they don't, you need to edit line 11 to point to whatever range contains the OrderNub data.
If not tables, then your projects at least use the exact same layout. In that case, you could change line 11 to something like: Set rng = ws.Range("C1").EntireColumn.Find(strOrder)
The code name of the master list is MasterList. This is not the same as the worksheet name as seen on the tab. This is the VBA code name. I prefer to use that as it is less likely to be changed and break the check. You can find the codename in the VBA editor. For instance, in this screenshot, the codename for the first worksheet is shtAgingTable and the name - as shown on the tab in Excel - is AgingTable.
This is a function, not a subroutine. That means you don't run it once. It's meant to be used like any other built-in function like SUM, IF, whatever. For instance, you can use the following formula in cell B2:
=FindMyOrderNumber($A2)
I am trying to loop through some columns in a row and create new worksheets with the name of the value of the current column/row that I am in.
Sub test()
Range("R5").Select
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Loop
End Sub
This code creates the first one correctly starting at R5 but then it appears that the macro switches to that worksheet and doesn't complete the task.
The Sheets.Add automatically moves your selection to the newly created sheet (just like if you insert a new sheet by hand). In consequence the Offset is based on cell A1 of the new sheet which now has become your selection - you select an empty cell (as the sheet is empty) and the loop terminates.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set MyNames = Range("R5").CurrentRegion ' load contigeous range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell children of range variable
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
This will work better .... you assign the list of names to an object variable of type Range and work this off in a For Each loop. After you finish you put your Selection back to where you came from.
Sheets.Add will automatically make your new sheet the active sheet. Your best bet is to declare variables to your objects (this is always best practice) and reference them. See like I've done below:
Sub test()
Dim wks As Worksheet
Set wks = Sheets("sheet1")
With wks
Dim rng As Range
Set rng = .Range("R5")
Do Until IsEmpty(rng)
Sheets.Add.Name = rng.Value
Set rng = rng.Offset(0, 1)
Loop
End With
End Sub
Error handling should always be used when naming sheets from a list to handle
invalid characters in sheet names
sheet names that are too long
duplicate sheet names
Pls change Sheets("Title") to match the sheet name (or position) of your title sheet
The code below uses a variant array rather than a range for the sheet name for performance reasons, although turning off ScreenUpdating is likely to make the biggest difference to the user
Sub SheetAdd()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim strError As String
Dim vArr()
Dim lngCnt As Long
Dim lngCalc As Long
Set ws1 = Sheets("Title")
vArr = ws1.Range(ws1.[r5], ws1.[r5].End(xltoRight))
If UBound(vArr) = Rows.Count - 5 Then
MsgBox "sheet range for titles appears to be empty"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
End With
For lngCnt = 1 To UBound(vArr)
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = vArr(lngCnt, 1)
If Err.Number <> 0 Then strError = strError & vArr(lngCnt, 1) & vbNewLine
On Error GoTo 0
Next lngCnt
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Len(strError) > 0 Then MsgBox strError, vbCritical, "These potential sheet names were invalid"
End Sub
This is probably the simplest. No error-handling, just a one-time code to create sheets
Sub test()
Workbooks("Book1").Sheets("Sheet1").Range("A1").Activate
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
Workbooks("Book1").Sheets("Sheet1").Select
ActiveCell.Offset(0, 1).Select
Loop
End Sub