I have 10 columns in a worksheet with every worksheet having a specified ID defined in the namebox. How can I store the ID's in an Array using VBA.
p.s. I do not want to store the column headings. I want to store their ID's Which are defined in the namebox for every column.
Loop through the workbook's named ranges; check that each name refers to a range on that worksheet and that the named range refers to a range that is at least partially in the first row.
Dim n As Long, vColNames As Variant
Dim c As Long, twb As Workbook
Set twb = ThisWorkbook
With Worksheets("Sheet1")
With .Cells(1, 1).CurrentRegion
'dim the array one-based to parallel the columns
ReDim vColNames(1 To .Columns.Count)
'loop through all names looking for ones that intersect first row
For n = 1 To twb.Names.Count
'check the parent worksheet first
If twb.Names(n).RefersToRange.Parent.Name = .Parent.Name Then
' next check to ensure first row is part of named range
If Not Intersect(twb.Names(n).RefersToRange, .Rows(1), .Cells) Is Nothing Then
vColNames(Intersect(twb.Names(n).RefersToRange, .Rows(1)).Cells(1, 1).Column) = _
twb.Names(n).Name
End If
End If
Next n
End With
End With
For c = LBound(vColNames) To UBound(vColNames)
Debug.Print vColNames(c)
Next c
Names with workbook scope will come out as myNamedRange; those with worksheet scope will be in the form of Sheet1!myNamedRange.
Related
I have the following Problem:
I have two (dynamic) lists that are named MarketsEquities and MarketsBonds and are found on worksheets SummaryEquities and SummaryBonds, respectively.
I then have a worksheet named PnL where I want to create a list of the markets listed in the previous worksheets. These Markets should all be listed in column C and a space should be provided between the end of the equities list and the start of the bond list, wherein I shall write in column B Bonds.
This is what I've got thus far:
Sub InsertEquitiesBonds()
Dim ws As Worksheet, r1 As Range, r2 As Range
Set ws = Worksheets("PnL")
ws.Activate
Set Range("B3").Value = "Equities"
Set r1 = Worksheets("SummaryEquities").Range("MarketsEquities")
r1.Copy Range("C4")
'I want to then insert "Bonds" in Column B at the end of the listing of equities and then list all bonds in column C below that.
Set r2 = Worksheets("SummaryBonds").Range("MarketsBonds")
End Sub
Help is greatly appreciated.
I recommend to specify a worksheet for every Range() or Cells() statement like ws.Range("C4") otherwise Excel guesses which worksheet you mean.
You can determine the last used cell in a column with
ws.Cells(ws.Rows.Count, "B").End(xlUp) 'last used cell in column B
and you can use .Offset(row, column) to move rows/columns relatively from that cell.
So I suggest the following:
Public Sub InsertEquitiesBonds()
Dim ws As Worksheet
Set ws = Worksheets("PnL")
ws.Range("B3").Value = "Equities"
Worksheets("SummaryEquities").Range("MarketsEquities").Copy ws.Range("C4")
Dim LastUsedCell As Range
Set LastUsedCell = ws.Cells(ws.Rows.Count, "B").End(xlUp) 'last used cell in column B
LastUsedCell.Offset(2, 0).Value = "Bonds" 'move 2 cells down and write Bonds
Worksheets("SummaryBonds").Range("MarketsBonds").Copy LastUsedCell.Offset(3, 1) 'copy MarketsBonds 3 cells down and one cell right of the last used cell
End Sub
I have a somewhat simple macro that I have made but I am rusty as I have not coded in a few years. As simply as I can put it, I Have two different Workbooks. If the workbook I have open has a certain value (or no value), I want it to fill the other workbook("Test Template") with either "proposal or pre-proposal."
That has all been easy for me. But since the worksheet adds rows as we input data, I need it to fill those values in the next available row.
I will attach code but don't worry about the proposal stuff, I just need the range changed from a specific cell into the next available cell in the column. (if d28 is full, put in d29).
Public Sub foo()
Dim x As Workbook
Dim y As Workbook
'## Open both workbooks first:
Set x = ActiveWorkbook
Set y = Workbooks.Open("C:\Users\hmaggio\Desktop\Test Template.xlsx")
'copy Names from x(active):
x.Sheets("Sheet1").Range("C4").Copy
'paste to y worksheet(template):
y.Sheets("Sheet1").Range("B28").PasteSpecial
If x.Sheets("Sheet1").Range("C15") = "" Then
y.Sheets("Sheet1").Range("D28").Value = "proposal"
Else
y.Sheets("Sheet1").Range("D28").Value = "preproposal"
End If
First, you need a variable where you'll store the last used row number:
dim lngRows as long
lngRows = Cells(Rows.Count, "D").End(xlUp).Row
Then replace your lines of code where you have .Range("B28") with either .Cells(lngRows+1,2) or .Range("B"&lngRows)
The object Range offers a method called End that returns the last range on a certain direction.
Range("A1").End(xlDown) '<-- returns the last non-empty range going down from cell A1
Range("A1").End(xlUp) '<-- same, but going up
Range("A1").End(xlToRight) '<-- same, but going right
Range("A2").End(xlToLeft) '<-- same, but going left
In your case, hence, you can detect and use the last row of column B like this:
nextRow = y.Sheets("Sheet1").Range("B3").End(xlDown).Row + 1
More details:
The first Range of your column B is the header Range("B3")
You get the last filled range going down with .End(xlDown)
Specifically, you get the Row of that range
You add + 1 (cause you want the next available row
You store the row in the variable nextRow
... that you can then use like this:
y.Sheets("Sheet1").Range("B" & nextRow ).PasteSpecial
Try this
Public Sub foo()
Dim x As Workbook
Dim y As Workbook
Dim fromWs As Worksheet
Dim toWs As Worksheet
Dim Target As Range
'## Open both workbooks first:
Set x = ActiveWorkbook
Set y = Workbooks.Open("C:\Users\hmaggio\Desktop\Test Template.xlsx")
Set fromWs = x.Sheets("Sheet1")
Set toWs = y.Sheets("Sheet1")
With fromWs
Set Target = toWs.Range("b" & Rows.Count).End(xlUp)(2) '<~~next row Column B cell
Target = .Range("c4") 'Column B
If .Range("c15") = "" Then
Target.Offset(, 2) = "proposal" 'Column D
Else
Target.Offset(, 2) = "preproposal"
End If
End With
End Sub
I have workbook A with many columns and headers, I would like to separate this data and populate into workbook B based on header name(workbook B has 4 sheets of different pre populated column headers)
1) Workbook A (many columns), filter for all its unique values in col 'AN' (ie. col AN has 20 unique values but ~3000 rows each for each unique set).
2) There is workbook B, with pre populated columns in 4 sheets, not all are the same headers as in workbook A. Here is where the unique values from col AN from workbook A with their respective records will be populated, one after the other.
The goal here is to populate these 4 sheets with data from Workbook A, sorting by each unique column AN value, with its records into the prepopulated workbook B.
This code so far just filters my main 'AN' column uniquely and just gets unique values, I need unique values along with records.
Sub Sort()
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As Range, intRow As Long, i As Integer
Dim r As Range, lr As Long, myrg As Range, z As Range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
Dim lngLastNode As Long, lngLastScen As Long
' Finds column AN , header named 'first name'
intColScenario = 0
On Error Resume Next
intColScenario = WorksheetFunction.Match("First name", .Rows(1), 0)
On Error GoTo 0
If intColScenario > 0 Then
' Only action if there is data in column E
If Application.WorksheetFunction.CountA(.Columns(intColScenario)) > 1 Then
lr = .Cells(.Rows.Count, intColScenario).End(xlUp).Row
' Copy unique values from the formula column to the 'Unique data' sheet, and write sheet & file details
.Range(.Cells(1, intColScenario), .Cells(lr, intColScenario)).AdvancedFilter xlFilterCopy, , r, True
r.Offset(0, -2).Value = ws.Name
r.Offset(0, -3).Value = ws.Parent.Name
' Delete the column header copied to the list
r.Delete Shift:=xlUp
boolWritten = True
End If
End If
'I need to take the rest of the records with this though.
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
Adding sample pictures
Workbook A sample, I want to unique filter the 'job column' to get all like records together:
Workbook sample B,
Sheet 1 (note there will be multiple sheets).
As you can see workbook A has been sorted by the 'job' column.
you could use the following code:
edited to account for workbook "B" worksheets headers in row 2 (instead of row 1 as per OP example)
Option Explicit
Sub main()
Dim dsRng As Range
Dim sht As Worksheet
Dim AShtColsList As String, BShtColsList As String
Set dsRng = Workbooks("A").Worksheets("ShtA").Range("A1").CurrentRegion '<--| set your entire data set range in workbook "A" worksheet "ShtA" (change "A" and "ShtA" to your actual names)
dsRng.Sort key1:=dsRng.Range("AN1"), order1:=xlAscending, Header:=xlYes '<--| sort data set range on its 40th column (which is "AN", beginning it from column "A")
With Workbooks("B") '<--| refer "B" workbook
For Each sht In .Worksheets '<--| loop through its worksheets
GetCorrespondingColumns dsRng, sht, AShtColsList, BShtColsList '<--| build lists of corresponding columns indexes in both workbooks
CopyColumns dsRng, sht, AShtColsList, BShtColsList '<--| copy listed columns between workbooks
Next sht
End With
End Sub
Sub GetCorrespondingColumns(dsRng As Range, sht As Worksheet, AShtColsList As String, BShtColsList As String)
Dim f As Range, c As Range
Dim iElem As Long
AShtColsList = "" '<--| initialize workbook "A" columns indexes list
BShtColsList = "" '<--| initialize workbook "B" current sheet columns indexes list
For Each c In Sht.Rows(2).SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through workbook "B" current sheet headers in row 2 *******
Set f = dsRng.Rows(1).Find(what:=c.value, lookat:=xlWhole, LookIn:=xlValues) '<--| look up data set headers row for workbook "B" current sheet current column header
If Not f Is Nothing Then '<--| if it's been found ...
BShtColsList = BShtColsList & c.Column & "," '<--| ...update workbook "B" current sheet columns list with current header column index
AShtColsList = AShtColsList & f.Column & "," '<--| ...update workbook "A" columns list with corresponding found header column index
End If
Next c
End Sub
Sub CopyColumns(dsRng As Range, sht As Worksheet, AShtColsList As String, BShtColsList As String)
Dim iElem As Long
Dim AShtColsArr As Variant, BShtColsArr As Variant
If AShtColsList <> "" Then '<--| if any workbook "B" current sheet header has been found in workbook "A" data set headers
BShtColsArr = Split(Left(BShtColsList, Len(BShtColsList) - 1), ",") '<--| build an array out of workbook "B" current sheet columns indexes list
AShtColsArr = Split(Left(AShtColsList, Len(AShtColsList) - 1), ",") '<--| build an array out of workbook "A" corresponding columns indexes list
For iElem = 0 To UBound(AShtColsArr) '<--| loop through workbook "A" columns indexes array (you could have used workbook "A" corresponding columns indexes list as well)
Intersect(dsRng, dsRng.Columns(CLng(AShtColsArr(iElem)))).Copy Sht.Cells(2, CLng(BShtColsArr(iElem))) '<--| copy data set current column into workbook "B" current sheet corresponding column starting from row 2 *******
Next iElem
End If
End Sub
and should really need to have each unique name rows set in workbook "B" sheets separated by a blank row, you can write a quite simple SubSeparateRowsSet() and call it right after CopyColumns() call in main()
Assume that this is my data in Excel Data containing duplicate values in the first three columns.
As you can see the values in the first three columns are repeated for a number of rows.
I want to remove the duplicate values in them just like this screenshot
duplicate values are removed using a macro
I decided to use a macro that does this for me automatically and I found this VBS code that removes the duplicate values. What the macro actually does is that it removes the repeating values in the selected area where the cursor is in, so each time the macro runs I have to select the area that I would like the values to be removed. But, what I want is to remove the duplicates from the columns A, B, and C whether or not they are selected and no matter how many rows there are. And, I want it to work on open automatically.
I considered using Range() instead of Selection() e.g. I put something like Set r = Columns("A:C").Select but that didn't work. Is there a way to do this in VBS?
Option Explicit
Private originalValues()
Private originalRange As String
Sub removeDupes()
Dim r As Range 'target range
Dim arr() 'array to hold values
Dim i As Long, j As Long, k As Long 'loop control
Dim upper1D As Long, upper2D As Long, lower2D As Long 'array bounds
Dim s As String 'temp string to compare values
Set r = Selection.Resize(Cells.SpecialCells(xlLastCell).Row)
If r.Rows.Count = 1 Then Exit Sub 'if the target range is only 1 row then quit
arr = r.Value 'copy the values in r to the array
'store the values for an undo
originalValues = r.Value
originalRange = r.Address
upper1D = UBound(arr) 'get the upper bound of the array's 1st dimension
upper2D = UBound(arr, 2) 'get the upper bound of the array's 2nd dimension
lower2D = LBound(arr, 2) 'get the lower bound of the array's 2nd dimension
'loop through 'rows' in the array
For i = LBound(arr) To upper1D
'loop through all the 'columns' in the current row
For j = lower2D To upper2D
s = arr(i, j) 'record the current array component value in s
'Check to see if duplicates exists in the target range
If Application.CountIf(r.Columns(j), s) > 1 _
And LenB(s) Then
'Duplicate found: if the end of the array has not ye been reached then
'loop through the remaining rows for this column, clearing duplicates
If i < upper1D Then
For k = i + 1 To upper1D
If arr(k, j) = s Then arr(k, j) = ""
Next k
End If
End If
Next j
Next i
'copy array back to target range
r.Value = arr
Application.OnUndo "Undo remove duplicates", "restoreOriginalValues"
End Sub
Private Sub restoreOriginalValues()
Range(originalRange).Value = originalValues
End Sub
Thanks,
Laleh
you have to hardcode the range, like :
with Worksheets("MySheet") '<~~ change the worksheet name as per your actual one
Set r = .Range("A2:C2", .Cells(.Rows.Count, "A").End(xlUp)) '<~~ assuming data are beginning from row 2, otherwise simply change row reference
end with
please consider it's always much safer to explicitly reference the Worksheet name in any Range
this should specially apply to restoreOriginalValues() sub since:
Address property of Range object would store the "pure" range cells address without any sheet reference
restoreOriginalValues could be possibly called after some "sheet-jumping"
so that you'd better define a module scoped Worksheet variable and then use it
Private originalValues()
Private originalRange As String
Private mySht As Worksheet '< ~~ set module scoped `Worksheet` variable
Sub removeDupes()
'... code
originalRange = dataRng.Address '<~~ store the "pure" range cells address without any sheet reference
'... code
End Sub
Private Sub restoreOriginalValues()
mySht.Range(originalRange).Value = originalValues '< ~~ combine module scoped `Worksheet` and `originalRange` variables
End Sub
here follows an alternative approach looping through cells instead of using arrays. it's just for reference since arrays are surely faster where lots of data are concerned
Option Explicit
Private originalValues()
Private originalRange As String
Private mySht As Worksheet
Sub removeDupes()
Dim cell As Range, compCell As Range
Dim headerRng As Range, dataRng As Range
Set mySht = Worksheets("MyData")
With mySht '<~~ change the worksheet name as per your actual one
Set headerRng = .Range("A2:C2") '<~~ change the header columns reference as per your needs
Set dataRng = Range(headerRng.Offset(1), .Cells(.Rows.Count, headerRng.Columns(1).Column).End(xlUp)) '<~~ set data range from row below headers to the row with last non empty cell in first header column
'store the values for an undo
originalValues = dataRng.Value
originalRange = dataRng.Address
For Each cell In dataRng '<~~ loop through every cell
Set compCell = IIf(IsEmpty(cell.Offset(-1)), cell.End(xlUp), cell.Offset(-1)) '<~~ set the cell whose value is to compare the current cell value to
If cell.Value = compCell.Value Then cell.ClearContents '<~~ clear current cell only if its value is the same of its "comparing" cell one
Next cell
End With
restoreOriginalValues
End Sub
Private Sub restoreOriginalValues()
mySht.Range(originalRange).Value = originalValues
End Sub
I want to find all the cells in Column L with a particular value and return the values in Column D of the same row as those cells found.
So far, I am only able to return one result, which would be the top most result in my list, but I want to find all the rest as well, which I don't know the code to use.
Just to further explain: Value in cell D11 is the value I want to find in Column L of sheet "Master List". Supposedly I find the value in cells L13, L15 and L20, I want to return the value in cell D13, D15 and D20 into cells "C37:C39" of ws. Note: no. of cells that have the value may vary so the values returned will just appear from C37 downwards (something like automatic multiple selection, copy and paste)
Here's a little something to start the ball rolling:
Sub FindRelatedProducts()
Dim cell As Excel.Range
Dim D11Value As Variant
Dim D11Row As Variant
Dim ws As Worksheet: Set ws = Sheets("RShip")
Set cell = ws.Range("D11")
D11Value = cell.Value
With Sheets("Master List")
D11Row = Application.Match(D11Value, .Range("L:L"), 0)
If Not IsError(D11Row) Then
ws.Range("C37") = .Range("D" & D11Row).Value
End If
End With
End Sub
Here's an example using range variables.
You'll want to define a range for the input data range and a range for the output data. Then in the VBA you will want to change the wrk, inRng and outRng variables to be the named ranges you defined and change the column indexes in the for and if blocks to match the column index of the data you are looking for.
Option Explicit
Option Base 1
Sub FindValues()
Dim wrk As Worksheet
Dim inRng As Range
Dim outRng As Range
Dim cntr As Long
Dim outCntr As Long
Dim findVal As Double
Set wrk = Worksheets("Data")
Set inRng = wrk.Range("LookupRange")
Set outRng = wrk.Range("OutputRange")
' Clear the output range in case you have fewer values on this run than on the previous one
outRng.ClearContents
' Set the value you are looking for
findVal = 1
' Iterate through the rows in the input range. If you find the result you want then write it to the output range
For cntr = 1 To inRng.Rows.Count
If inRng(cntr, 1) = findVal Then ' Assumes the value you are finding is in column 1 of the input range
outRng(outCntr, 1) = inRng(cntr, 2) ' Assumes the values you are exporting is in column 2 of the input range
outCntr = outCntr + 1
End If
Next cntr
End Sub