I have a project that I am working on where multiple conditions are checked across all rows and many columns. The issue is that columns are added/removed from the sheet, and, at present, that results in all of my cell(row,column) references being off + outputting incorrect information. I'm wondering if there's a way to make my column references more robust so that they automatically find the correct headers and use them when checking? Would a solution to this problem be able to account for multiple columns containing the exact same header text?
Basically:
No blank columns
Column headers have repeats (e.g., Column 1 header: "Financials"; Column 15 header: "Financials")
Columns are shifting right and left based on adding/removing columns from sheet
Please find a short sample of my current code below with notes:
Dim i As Integer
Dim lastRow As Long
Dim lastCol As Long
lastRow = Range("A1").End(xlDown).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To lastRow
Select Case Cells(i, 14).Value
Case Is = "Yes"
Select Case True
Case Cells(i, 63).Value = 6 And _
(IsEmpty(Cells(i, 77)) Or IsEmpty(Cells(i, 93)) Or IsEmpty(Cells(i, 109)) Or _
IsEmpty(Cells(i, 125)) Or IsEmpty(Cells(i, 141)) Or IsEmpty(Cells(i, 157)))
Cells(i, 174).Value = "True" '^THESE CELL VALUES ALL HAVE THE SAME COLUMN HEADER TITLE
If the table is consistent - starting at A1 and occupying a contiguous block - then Range("A1").CurrentRegion will reference the table.
You can then use .CreateNames to name the columns (that is, using Named Ranges) according to their headings.
Dim rngTable As Range
Dim rng As Range
Set rngTable = Range("A1").CurrentRegion
rngTable.CreateNames True, False, False, False
' that is, based on the first row headings
Range("Salary").Select 'prove it works
'if necessary, iterate the cells of the column,
For Each rng In Range("Salary")
rng.Value = rng.Value + 10
Next 'rng
If a column heading is duplicated ("Financial"), though, then you'll be asked to confirm and the second occurrence will overrule the first. (Or you could say "No" and the first occurrence will be named.) In which case, it is preferable that you first correct these duplicate headings.
Correcting the duplicate headings is not necessarily straight forward, but something that you should resolve anyway. If it is a specific word "Financials" (or words) that could be duplicated then this makes the task easier. You could count how many occurrences there are, and correct the second, etc., to "Financials2".
One easy way to to assign a Name to the column. Say column N has the header "Payments". First assign the Name "Payments" to that column:
Then in VBA we can code like:
Sub dural()
Dim rng As Range, colly As Long
Set rng = Range("Payments")
colly = rng.Column
For i = 2 To 100
If Cells(i, colly) = "whatever" Then
MsgBox "Help"
End If
Next i
End Sub
The code will continue to work even if you add/remove columns beforre column N.
Related
I am pretty new to VBA and I have been fighting with creating one simple report for many days so I decided to inquire for some help. I will be really grateful for any tips you have or could point to any errors I might've made in my code.
I have the below piece of code (extracted from my loop). What I want to do is to create a list based on around 20 excel files that will have below stats:
name of the current tab inside the workbook
count of nonblanks in a column which name contains word "Difference" (always in row 7 but can be in different columns)
count from the same column but where cells are not blank AND different than 0.
For the last stat I didn't even start so you won't see it in my code but I would appreciate if you have any tips for this one too (which method best to use).
Windows("PassRate.xlsm").Activate
b = ActiveSheet.Cells(Rows.count, 2).End(xlUp).Row + 1
Cells(b, 3) = xlWorkBook.Worksheets(i).Name
xlWorkBook.Worksheets(i).Activate
Set Myrng = Range("B7:M9999").Find(What:="Difference", LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False)
If Not Myrng Is Nothing Then
RowQnt = xlWorkBook.Worksheets(i).Myrng.Offset(9999, 2).Cells.SpecialCells(xlCellTypeConstants).count
End If
Windows("PassRate.xlsm").Activate
Cells(b, 4) = RowQnt
My problem is that the macro runs and works, but the result I get is the list of tab names but all counts are 0 and I cannot overcome this issue. For the line number 7 I've also tried the piece of code below which yields the same result.
RowQnt = xlWorkBook.Cells(Rows.count, Myrng).End(xlUp)
Is it possible that my problem is due to the fact that in the source files the column containing word "Difference" is sometimes two merged columns? Unfortunately, I cannot change that as these are some automatically generated files from another program.
xlWorkBook.Worksheets(i).Myrng isn't a valid Range syntax while you can simply use MyRng which you already set to a not null Range reference and already has both parent worksheet and workbook references inside it
but even Myrng.Offset(9999, 2).Cells wouldn't do since it references one cell only and not a range of cells
you need a Range(Range1, Range2) syntax, where both Range1 and Range2 are valid Range references to the first and last cell of the range you actually want to count not blank cells of
furthermore you could use WorksheetFunction.CountA() function instead of SpecialCells(xlCellTypeConstants) range, since this latter errors out if no constant cells are found in the range it's being applied to (so you'd need a check) while the former simply returns zero if no not empty cells are found
for all what above you could write the following GetRowQnt() function:
Function GetRowQnt(sht As Worksheet) As Long
Dim Myrng As Range
With sht '<--| reference passed worksheet
Set Myrng = .Rows(7).Find(What:="Difference", LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False) '<--| find "Difference" in its 7th row
If Not Myrng Is Nothing Then GetRowQnt = WorksheetFunction.CountA(.Range(.Cells(8, Myrng.Column), .Cells(WorksheetFunction.Max(.Cells(.Rows.count, Myrng.Column).End(xlUp).row, 8), Myrng.Column))) '<--| count not blank cells in column where "Difference" was found from row 8 down to its last not empty cell
End With
End Function
and use it in your main code as follows:
With Windows("PassRate.xlsm").ActiveSheet '<--| reference "PassRate.xlsm" workbook active sheet (or change 'ActiveSheet' with 'Worksheetes("yourSheetName")')
For i = 1 To xlWorkbook.Worksheets.count '<--| loop through 'xlWorkbook' workbook worksheets
b = .Cells(.Rows.count, 3).End(xlUp).row + 1 '<--| get "PassRate.xlsm" workbook active sheet current first empty cell in column "C"
.Cells(b, 3) = xlWorkbook.Worksheets(i).Name
.Cells(b, 4) = GetRowQnt(xlWorkbook.Worksheets(i))
Next
End With
please note that with
b = .Cells(.Rows.count, 3).End(xlUp).row + 1
I took column "C" as the leading one to get last not empty row from, since there was no code in your post that wrote something in column "B".
But if your real code has some
.Cells(b, 2) = somedata '<--| write something in column "B" current row
then you can go back to b = .Cells(.Rows.count, 2).End(xlUp).row + 1
I am new to Excel Macros and VBA, and am facing the following problem:
(1) I have a data-set which has ~50,000 rows and 11 columns.
(2) I need to extract rows from the sheet, based on a certain keyword - which matches the strings present in a particular column.
(3) I have the following code from another stack overflow question:
Sub testIt()
Dim r As Long, endRow as Long, pasteRowIndex As Long
endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
(4) This works perfectly fine when the cell of the column being searched has "YourCriteria" as the only entry.
(5) However, in my data I have strings which have the "YourCriteria" embedded in them
For Example: "YourCriteria" = "ball" and the cell(s) in a particular column contain "the dog plays with the ball" , "the ball is bad" etc.
How can I extract the rows containing 'YourCriteria" ? What modification to the code is needed ?
Thanks
To expand on Doug's answer,
If InStr(Cells(r, 2).Value, "YourCriteria")>0 Then 'Found
' ^ Column A=1, B=2, ...
Edit Change 2 to whatever column number you want to look in (C=3, D=4, ...). You can also use Columns("B").Column like you had it, if you're more comfortable with that.
I have found If InStr()>0 to be more reliable than If Instr() since InStr has lots of return-value options.
A general thought, to avoid future problems - rather than switching sheets, refer expressly to which sheet you mean. Example (not all code shown):
dim shSource as Sheet
set shSource = ActiveWorkbook.Sheets("Sheet1")
dim shDest as Sheet
set shDest = ActiveWorkbook.Sheets("Sheet2")
...
If InStr(shSource.Cells(r, 2).Value, "YourCriteria")>0 Then 'Found
shSource.Rows(r).Copy
shDest.Rows(pasteRowIndex).Select
shDest.Paste
There's a built in operator for this in VBA: Like. You can just replace the current test with this:
If Cells(r, Columns("B").Column).Value Like "*YourCriteria*" Then 'Found
InStr( [start], string, substring, [compare] )
Parameters or Arguments
start
Optional. It is the starting position for the search. If this parameter is omitted, the search will begin at position 1.
string
The string to search within.
substring
The substring that you want to find.
compare Optional. It is the type of comparison to perform. It can be one of the following values:
VBA Constant Value Explanation
vbUseCompareOption -1 Uses option compare
vbBinaryCompare 0 Binary comparison
vbTextCompare 1 Textual comparison
borrowed from http://www.techonthenet.com/excel/formulas/instr.php
The fastest way is to:
Apply a Filter to the data
Set a range variable = .SpecialCells(xlCellTypeVisible)
Use range.Copy Sheets("Sheet2").Range("A1") to copy the data straight to Sheet2
Sub DoIt()
Dim SearchRange As Range
Sheets("Sheet1").UsedRange.AutoFilter Field:=2, Criteria1:="=*Ball*", _
Operator:=xlAnd
Set SearchRange = Sheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible)
If Not SearchRange Is Nothing Then
SearchRange.Copy Sheets("Sheet2").Range("A1")
End If
End Sub
I have a report that I pull everyday that is placed in a very awekward format. It's contains a variable row count by 4 columns organized into unofficial tables based on the Name of each employee.
What I have is an employee name in column B preceded 2 blank rows above and followed by 1 blank row of data below.
What I want to accomplish is loop through the data, identify cells in column B <> blank, delete the entire 2 rows below that cell, and delete the entire 1 row above that cell.
Below is what I have so far. not much:
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long
Dim lastCol As Long
Dim i as integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1
If Cells(i, "B").Value <> "" Then
End Sub
without making major changes to your code, try this:
For i = lastRow To 1 Step - 1
If Cells(i, "B").Value <> "" Then
Range(Cells(i, "B").Offset(1), Cells(i, "B").Offset(2)).EntireRow.Delete 'delete two below
Cells(i, "B").Offset(-1).EntireRow.Delete ' delete one above
You already get to your non-blank cell (ie Cells(i,"b")). To reference a range in relation to a cell you already have, use OFFSET.
So, and in this order, you select a range of cells from one below your cell Offset(1) to two cells below Offset(2)'. Change this range toENTIREROW` for those cells, and delete.
Then you select the cell above Offset(-1), select the ENTIREROW and delete.
as per your question narrative you'd possibly need to delete all rows that has a blank cell in column "B"
should that be the issue than you could (disclaimer: test it on a copy sheet!) simply go like follows:
Sub test()
With ActiveWorkbook.Sheets(1)
.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub
I recently posted a question, and unfortunately did not get very far with any answers. I have re-worked my macro to mirror a similar scenario I found elsewhere. The problem is I am now getting stuck at the very end.
Purpose of the macro:
1. Beneath the selected cell, I need to insert x new rows = entered months -1
In the first inserted row, I need a set of relative formulas that can be found in the Actual Row 2 of the current worksheet (basically copy and paste row 2 into the first row created)
In the subsequent inserted rows, I need a set of relative formulas that can be found in the Actual Row 3 of the current worksheet
As is, the macro does what I want, except I don't know how to paste row 3 in all subsequent rows. I'm assuming I need some conditional statement?
As mentioned in my last post, I am trying to teach myself VBA, so any help would be appreciated!!
Sub InsertMonthsAndFillFormulas(Optional vRows As Long = 0)
Dim x As Long
ActiveCell.EntireRow.Select 'So you do not have to preselect entire row
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Enter the total number of months in the program", Title:="Add Months", _
Default:=1, Type:=1) 'Default for 1 row, type 1 is number
If vRows = False Then Exit Sub
End If
Dim sht As Worksheet, shts() As String, i As Long
ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
Windows(1).SelectedSheets.Count)
i = 0
For Each sht In _
Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name
x = Sheets(sht.Name).UsedRange.Rows.Count 'lastcell fixup
Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows - 1).Insert Shift:=xlDown
Rows(2).EntireRow.Copy Destination:=Selection.Offset(1).Resize( _
rowsize:=1)
Rows(3).EntireRow.Copy Destination:=Selection.Offset(2).Resize( _
rowsize:=1)
On Error Resume Next
Next sht
Worksheets(shts).Select
End Sub
Ok, based on your comments, the below code should meet your needs. But first, a few things to note.
I've added several comments to help you understand what is happening in the code.
Based on your comment regarding vRows, the code will now terminate if the user keeps the default input box value ("1"). The logic is that if the value is only one, then no rows need to be added. Notice that I subtract 1 from the Inputbox value.
The code assumes you have headers or at least filled cells in row one. I use row one to find the last used column.
If there's any chance that the wrong sheet can be active when this code is executed, uncomment line 16 of my code. (Obviously you'd need to change the code to reflect your sheet's name.
Finally, this code assumes that the upper-left corner of your dataset is in A1.
Tested on Sample Dataset
Sub InsertMonthsAndFillFormulas(Optional vRows As Long = 0)
Dim lastCol As Long
Dim r As Range
'Ask user for number of months.
'If the user keeps the default value (1), exit sub.
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Enter the total number of months in the program", Title:="Add Months", _
Default:=1, Type:=1) - 1
If vRows = 0 Then Exit Sub
End If
'Uncomment this line if you are concerned with which sheet needs to be active.
'ThisWorkbook.Sheets("YourSheet").Select
With ActiveSheet
'Set the range to work with as the cell below the active cell.
Set r = ActiveCell.Offset(1)
'Find the last used column. (Assumes row one contains headers)
'Commented this out to hard-code the last column.
'lastCol = .Rows("1:1").Find("*", searchdirection:=xlPrevious).Column
'Insert the new rows.
r.EntireRow.Resize(vRows).Insert Shift:=xlDown
'r needs to be reset since the new rows pushed it down.
'This time we set r to be the first blank row that will be filled with formulas.
Set r = .Range(.Cells(ActiveCell.Offset(1).Row, 1), _
.Cells(ActiveCell.Offset(1).Row, "H")) '<~~ Replaced lastCol with "H"
'**Add formulas to the new rows.**
'Adds row two formulas to the first blank row.
.Range(.Cells(2, 1), .Cells(2, "H")).Copy r
'Adds row three formulas to the rest of the blank rows.
.Range(.Cells(3, 1), .Cells(3, "H")).Copy r.Offset(1).Resize(vRows - 1)
End With
End Sub
Edit
The variable lastCol is what defines the right most column to copy formulas from. This variable is set using column headers in row 1. I prefer using variables like this to make the code more robust (i.e. you can add a column to your dataset without breaking the macro), however, for this to work you need headers above every used column (or at least cells that contain values).
If you aren't concerned with adding more columns in the furture, you can hard-code the last column into the code (see my revisions).
I'm just getting started with VBA for Excel. I used VB and Java in college nearly ten years ago and was competent with it then, but am essentially starting over. (Um, not like riding a bike.)
I am trying to understand the methods to build a range that isn't just declared as A1:J34 or whatever. My Googling is challenged in that when searching for 'range' and terms that indicate what I seek, I get an avalanche of hits far more advanced than what I need, mostly hits that don't even address the basic summary info I need.
So, here's the basics of it:
Excel 2011 on Mac.
The sheet has data from A to M, down to 1309.
It's a repeating pattern of heading rows followed by data rows. Ugh. Seems like the person creating the sheet was more thinking about printing from the sheet than the organisation of the data. I need to clean it and 3 more like it up to use in a pivot table, and it's useless in this silly repeating layout.
Heading rows are as follows:
Last Name, First Name, then 10 date cells.
Data rows under the headings are the names, of course, and then a 1 or 0 for attendance.
Anywhere from 20 to 30 names under each heading. Then it repeats. And the dates change every few sets, picking up where the last set left off.
What I need to do right now:
I'm trying to assemble a range into a range variable by adding all the rows beginning with a specific value (in column A). In my case that value is the string "Last Name", so I can have the range variable holding all the cells in all rows that begin with "Last Name". This will then capture all the cells that need to be in date format. (I'm doing it so I can then make sure the date headings are all actually IN date format - because they are NOT all in date format now, many are just 'General' cells.)
My questions:
When telling a range object what it's range IS, how do you feed it cells/rows/columns that are not just a block defined by start and end cells entered by the person writing the code but based on row criteria? Eg: Create a Range that has rows 1, 34, 70, 93, and 128 from columns A to I based on presence of "First Name" in A.
What are the most common methods to do this?
Which of these is best suited to my need and why?
Here's a working example that demonstrates finding the "Last Name" rows, contructing a range object that includes all those rows, and then iterating through that object to search for non-date values. The code could be speeded up greatly by reading the data range into an array of variants and then searching the array for both the last name rows and the "bad dates" within those rows. This is especially true if you have a very large number of rows to check.
Sub DisjointRng()
Dim checkCol As String, checkPattern As String
Dim dateCols()
Dim lastCell As Range, usedRng As Range, checkRng As Range
Dim cell As Variant
Dim usedRow As Range, resultRng As Range, rngArea As Range
Dim i As Long, j As Long
checkCol = "A" 'column to check for "Last Name"
checkPattern = "Last*"
dateCols = Array(3, 5) 'columns to check for date formatting
With Worksheets("Sheet1")
'find the bottom right corner of data range; we determine the used range
'ourselves since the built-in UsedRange is sometimes out-of-synch
Set lastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
Set usedRng = .Range("A1:" & lastCell.Address)
'the column of values in which to look for "Last Name"
Set checkRng = .Range(checkCol & "1:" & checkCol & usedRng.Rows.Count)
End With
'step down the column of values to check for last name & add
'add found rows to range object
For Each cell In checkRng
If cell.Value Like checkPattern Then
'create a range object for the row
Set usedRow = Intersect(cell.EntireRow, usedRng)
If resultRng Is Nothing Then
'set the first row with "Last Name"
Set resultRng = usedRow
Else
'add each additional found row to the result range object
Set resultRng = Union(resultRng, usedRow)
End If
End If
Next cell
For Each rngArea In resultRng.Areas
'if found rows are continguous, Excel consolidates them
'into single area, so need to loop through each of the rows in area
For i = 1 To rngArea.Rows.Count
For j = LBound(dateCols) To UBound(dateCols)
If Not IsDate(rngArea.Cells(i, dateCols(j))) Then
'do something
End If
Next j
Next i
Next rngArea
End Sub
You can use the Union operator, like this
Dim r As Range
Set r = Range("A1, A3, A10:A12")
or this
Set r = Union(Range("A1"), Range("A3"), Range("A10:A12"))
You can the iterate this range like this
Dim cl as Range
For Each cl in r.Cells
' code cell cl
Next
or this
Dim ar as Range
For each ar in r.Areas
' code using contiguous range ar
For each cl in ar.Cells
' code using cell cl
Next
Next