I have one workbook with many order numbers in many different columns(20+). Each Column has a different Header(column name) that can be found in the first row.
On a different sheet I will have all of the order numbers compiled into column A. In column B I would populate the name of the column (header) for each order number.
The code below would provide me a function to return the sheet name. In line 14 I tried changing w.s. name to header but it would not work.
Option Explicit
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
Application.Volatile
For Each ws In Worksheets
If ws.CodeName <> "Sheet3" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole)
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
FindMyOrderNumber = ws.Cells(1, rng.Column)
From your description it sounds like you want to return the same value you're passing into the function...
If you mean you want to return the column letter where the header was found then edit the lines below:
'On Error Resume Next 'don't need this...
Set rng = ws.Rows(1).Find(What:=strOrder, LookAt:=xlWhole)
'On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = Replace(rng.Address(False, False),"1","")
Exit For
End If
EDIT: To return the value in the cell below the header:
'On Error Resume Next 'don't need this...
Set rng = ws.Rows(1).Find(What:=strOrder, LookAt:=xlWhole)
'On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = rng.Offset(1,0).Value
Exit For
End If
Related
Below is my code. All of the code works, but I get error 438 object doesn't support this property or method vba in this line. i.offset(-7,-8).paste
Sub insert_6_rows()
Dim rActive As Range
Dim wb As Workbook
Set rActive = ActiveCell
Application.ScreenUpdating = False
Dim f As Range
Set f = Sheets("Format").Range("A1:J6")
Dim FindST As Range
Set FindST = Sheets("Driver").Range("I:I").Find(What:="Subtotal", LookIn:=xlValues)
FindST.Offset(-1, 0).EntireRow.Resize(6).Insert
f.Copy
Dim i As Range
Set i = Sheets("Driver").Range("I:I").Find(What:="Subtotal", LookIn:=xlValues)
i.Offset(-7, -8).Paste
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Use the Destination argument of a Range.Copy method.
Sub insert_6_rows()
Dim rActive As Range
Dim wb As Workbook
Set rActive = ActiveCell
Application.ScreenUpdating = False
Dim f As Range, FindST As Range, i As Range
Set f = workSheets("Format").Range("A1:J6")
Set FindST = workSheets("Driver").Range("I:I").Find(What:="Subtotal", LookIn:=xlValues)
FindST.Offset(-1, 0).EntireRow.Resize(6).Insert
f.Copy Destination:=workSheets("Driver").cells(FindST.row-1, "A")
rActive.select
Application.ScreenUpdating = True
End Sub
Use meaningful variable names! Everyone would think of i is a simple counter. Eg. better name it FoundCell.
If nothing is found then you cannot .Offset from "nothing", that's why it fails. So you will need to test if something was found.
I suggest:
Dim FoundCell As Range
Set FoundCell = Sheets("Driver").Range("I:I").Find(What:="Subtotal", LookIn:=xlValues)
'check if something was found
If FoundCell is Nothing Then
MsgBox "Subtotal not found in column I"
Exit Sub
End If
'check if found cell.row is at least 7 rows so we can offset -7
If FoundCell.Row <= 7 Then
MsgBox "Cannot offset -7 rows because found cell is less then 7 rows from top"
Exit Sub
End If
SourceRange.Copy
FoundCell.Offset(-7, -8).Paste
Change Paste to PasteSpecial
i.Offset(-7, -8).PasteSpecial
I have a challenge... I have a range in Sheet Lookup with each possible value in Pivot table filter "Owner: Full Name".
The range with the names are Sheets "Lookup" Range B2:B98. (Problem 1: This range can change as it creates this list in a different code, how to set this to a dynamic range?)
Once it filters on that i.e. value in B2 it should copy this filtered pivot into a new sheet and name the sheet after the value in b2.
Then it should "deselect" the b2 item and go to filter on value in b3 and continue.
Problem 2: Setting the filter correctly to loop and filter on each single value in the new dynamic lookup range.
Here is what I have at the moment...
Option Explicit
Dim wb As Workbook, ws, ws1, ws2 As Worksheet, PT As PivotTable, PTI As
PivotItem, PTF As PivotField, rng As Range
Sub Filter_Pivot()
Set wb = ThisWorkbook
Set ws = wb.Sheets("Copy")
Set ws1 = wb.Sheets("Lookup")
Set PT = ws.PivotTables("PivotCopy")
Set PTF = PT.PivotFields("Owner: Full Name")
For Each rng In ws1.Range("B2:B98")
With PTF
.ClearAllFilters
For Each PTI In PTF.PivotItems
PTI.Visible = (PTI.Name = rng)
Next PTI
Set ws2 = Sheets.Add
ws1.Name = PTI
.TableRange2.Copy
ws2.Range("A1").PasteSpecial
End With
Next rng
End Sub
You might be able to avoid all this and use the PivotTable.ShowPages Method. It is optimized for this sort of operation.
Note:
"Owner: Full Name" must be in the page field area at the top.
You probably want to check the sheet names don't already exist. You could do an initial loop of sheet names that will be generated from pivot and try deleting them (wrapping inside an On Error Resume Next, attempt delete, On Error GoTo 0) to ensure they don't exist first. I have shown how to do this in the second example.
Info: PivotTable.ShowPages Method
Creates a new PivotTable report for each item in the page field. Each
new report is created on a new worksheet.
Syntax expression . ShowPages( PageField )
expression A variable that represents a PivotTable object.
[Optional parameter of pageField.]
Code:
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
This will produce a sheet for each possible value in the page field "Owner: Full Name". If you don't want all of them, simply hold a list of sheet names for sheets to keep, in an array, and loop over all sheets in workbook and if not in array then delete as shown below:
① Example of looping sheets and deleting if not in array:
Option Explicit
Public Sub GeneratePivots()
Dim keepSheets(), ws As Worksheet
keepSheets = Array("FilterValue1", "FilterValue2","Lookup","Copy") '<== List of sheet names to keep
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo errHand
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, keepSheets, 0)) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
errHand:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
② Using a lookup sheet:
If you do want to still read in the sheets to keep from the Copy sheet then you can use the following (but be sure to include in the list in column B the sheet names Copy,Lookup, the filter values of interest, and any other sheet names you don't want deleted):
Code:
Option Explicit
Public Sub GeneratePivots()
Dim ws As Worksheet, lookups As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook.Worksheets("Lookup")
Set lookups = .Range(.Range("B2"), .Range("B2").End(xlDown))
If Application.WorksheetFunction.CountA(lookups) = 0 Then Exit Sub
keepSheets = lookups.Value
End With
Dim rng As Range
For Each rng In lookups
On Error Resume Next
Select Case rng.Value
Case "Lookup", "Copy" '<=Extend for sheets to keep listed in lookups that aren't generated by the pivot filtering
Case Else
ThisWorkbook.Worksheets(rng.Value).Delete
End Select
On Error GoTo 0
Next rng
On Error GoTo errHand
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Application.WorksheetFunction.Index(keepSheets, 0, 1), 0)) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
errHand:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Example run:
You may try something like this...
Sub Filter_Pivot()
Dim wb As Workbook
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim PT As PivotTable
Dim PTF As PivotField
Dim rng As Range
Dim lr As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Copy")
Set ws1 = wb.Sheets("Lookup")
Set PT = ws.PivotTables("PivotCopy")
Set PTF = PT.PivotFields("Owner: Full Name")
lr = ws1.Cells(Rows.Count, 2).End(xlUp).Row
For Each rng In ws1.Range("B2:B" & lr)
PTF.ClearAllFilters
On Error Resume Next
PTF.CurrentPage = rng.Value
If Err = 0 Then
Set ws2 = Sheets(rng.Value)
ws2.Cells.Clear
If ws2 Is Nothing Then
Set ws2 = Sheets.Add
ws2.Name = rng.Value
End If
PT.TableRange2.Copy ws2.Range("A1")
End If
PTF.ClearAllFilters
Set ws2 = Nothing
On Error GoTo 0
Next rng
End Sub
I'm trying to create a macro which will hide/unhide a specified range of columns.
Adding a column within the named range isn't problematic, but when adding a column at the borders of this range - macro doesn't work. For example, AM:BF is the named range ("Furniture") in my sheet. I need to add a column BG which will also be hidden by the macro. Same story when adding a new column on the left border. Could you guide me how to improve the code so that the columns added at the borders of the range will also be hidden/unhidden?
With ThisWorkbook.Sheets("Sheet1").Range("Furniture").EntireColumn
.Hidden = Not .Hidden
End With
I've added a variable RangeName (of type String) that equals to the name of the Name Range = "Furniture".
Code
Option Explicit
Sub DynamicNamedRanges()
Dim WBName As Name
Dim RangeName As String
Dim FurnitureNameRange As Name
Dim Col As Object
Dim i As Long
RangeName = "Furniture" ' <-- a String representing the name of the "Named Range"
' loop through all Names in Workbook
For Each WBName In ThisWorkbook.Names
If WBName.Name Like RangeName Then '<-- search for name "Furniture"
Set FurnitureNameRange = WBName
Exit For
End If
Next WBName
' adding a column to the right of the named range (Column BG)
If Not FurnitureNameRange Is Nothing Then '<-- verify that the Name range "Furnitue" was found in workbook
FurnitureNameRange.RefersTo = FurnitureNameRange.RefersToRange.Resize(Range(RangeName).Rows.Count, Range(RangeName).Columns.Count + 1)
End If
' loop through all columns of Named Range and Hide/Unhide them
For i = 1 To FurnitureNameRange.RefersToRange.Columns.Count
With FurnitureNameRange.RefersToRange.Range(Cells(1, i), Cells(1, i)).EntireColumn
.Hidden = Not .Hidden
End With
Next i
End Sub
place the following in your worksheet code pane:
Option Explicit
Dim FurnitureNameRange As Name
Dim adjacentRng As Range
Dim colOffset As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim newRng As Range
If colOffset = 1 Then Exit Sub
On Error GoTo ExitSub
Set adjacentRng = Range(adjacentRng.Address)
With ActiveSheet.Names
With .Item("Furniture")
Set newRng = .RefersToRange
.Delete
End With
.Add Name:="Furniture", RefersTo:="=" & ActiveSheet.Name & "!" & newRng.Offset(, colOffset).Resize(, newRng.Columns.Count + 1).Address
End With
ExitSub:
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Set FurnitureNameRange = ActiveSheet.Names("Furniture") 'ThisWorkbook.Names("Furniture")
On Error GoTo 0
colOffset = 1
Set adjacentRng = Nothing
If FurnitureNameRange Is Nothing Then Exit Sub
Set adjacentRng = Target.EntireColumn
With FurnitureNameRange.RefersToRange
Select Case Target.EntireColumn.Column
Case .Columns(1).Column - 1
colOffset = -1
Case .Columns(.Columns.Count).Column + 1
colOffset = 0
End Select
End With
End Sub
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.
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)