Set a range object with variables and offset from an activecell - excel

Can someone pls point out my error.
I'm trying to set a range object to be comprised of a Range1 and an Offset from Range1. There is a table of values I will be passing from into; hence the variables in the range object variable.
Original Error:Run-time Error '1004' Method "Range" of object_global failed.
Essentially I'm looking for (example) result: Range("A2:B94") where A is known, 2-is unknown, B94 is offset n-columns and n-rows from A2.
Below is a revised sub using resize method, yet it still has an error.
Sub comptst()
Dim line0 As Long, nrow0 As Long, ncol0 as long, diff0 As Long
Dim k As Integer
Dim rng0 As Range
Application.DisplayAlerts = False 'turns off alert display for deleting files sub-routine
For k = 6 To Sheets.Count 'tst_1 is indexed at position 5.
ThisWorkbook.Sheets(k).Activate
Set fsobj = New Scripting.FileSystemObject
If Not fsobj.FileExists(Range("A1")) Then MsgBox "File is missing on sheet index-" & k
Cells(1, 1).Select 'find starting row number
Do
If ActiveCell.Value = "Latticed" Then
b0 = ActiveCell.row 'starting row position
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
DoEvents '
Loop
Cells(4, 1).Select
Do Until ActiveCell.row = b0
line0 = ActiveCell.Value
nrow0 = ActiveCell.Offset(0, 1).Value
ncol0 = ActiveCell.Offset(0, 2).Value - 1
diff0 = b0 - 1
Set rng0 = ThisWorkbook.Sheets(k).Cells(line0 + diff0, 1).Resize(nrow0, ncol0)
diff0 = diff0 - 1
Debug.Print rng0.Address
ActiveCell.Offset(1, 0).Select
DoEvents
Loop
Next k
End Sub

You can use the Range.Resize-method. Also, it is often easier to use the Cells-property when coding as it takes numeric parameters for row and column.
Also, you should always specify on which sheet you are working, else VBA will use the ActiveSheet and that may or may not be the sheet you want to work with.
You have some issues with your variable declarations:
o Dim line0, nrow0, ncol0 As Double will declare line0 and nrow0 as Variant and only ncol0 as Double. You need to specify the type for every variable.
o You should declare all variables the deal with row or column numbers as Long. Integer may give you an overflow and Double makes not much sense as the numbers have never a fraction part.
If I understand your code correctly you could use
Dim line0 as Long, nrow0 as Long, ncol0 As Long, diff0 As Long
With ThisWorkbook.Sheets(1) ' <-- Replace with the book & sheet you want to work with
Set rng0 = .Cells(line0 + diff0, 1).resize(nrow0, ncol0)
End With

Related

Find range of cells, when given 2 Dates

I have a table with numbers from 1 to 10. (Starting from D2 to M2)
Suppose in A1 there is 03/09/2019
AND in B1 there is 06/09/2019
AND in C1 there is Hello
In COLUMN A I have a multiple series of words starting from A3 to A10
Here is an Example of the Excel Table
What I would like to do is: Search for the word Student in Column A, when I find it, get the numbers from A1 --> 3
and A2 --> 6 and write the word Hello that is in C1 in the cells that go to 3 to 6 in the row of the finded word Student
So my output would be like:
This is my code so far:
Dim Cell As Range
Columns("A:A").Select
Set Cell = Selection.Find(What:="Student", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Cell Is Nothing Then
MsgBox "Word not found"
Else
MsgBox "Word found"
End If
Basically I can find the word Student but don't know how to write the word Hello in the cells between 3 to 6
A few notes regarding the code below (not tested!).
1) Always try use worksheet qualifiers when working with VBA. This will allow for cleaner code with less room for unnecessary errors
2) When using .Find method I use LookAt:=xlWhole because if you do not explicitly define this your code will use the last known method that you would have used in Excel. Again, explicit definition leaves less room for error.
3) Try include error handling when you code. This provides “break points” for easier debugging in the future.
4) You can make the below much more dynamic that it currently is. But I'll leave that up to you to learn how to do!
Option Explicit
Sub SearchAndBuild()
Dim rSearch As Range
Dim lDayOne As Long, lDayTwo As Long
Dim lColOne As Long, lColTwo As Long
Dim sHello As String
Dim wsS1 As Worksheet
Dim i As Long
'set the worksheet object
Set wsS1 = ThisWorkbook.Sheets("Sheet1")
'store variables
lDayOne = Day(wsS1.Range("A1").Value)
lDayTwo = Day(wsS1.Range("B1").Value)
sHello = wsS1.Range("C1").Value
'find the student first
Set rSearch = wsS1.Range("A:A").Find(What:="Student", LookAt:=xlWhole)
'error handling
If rSearch Is Nothing Then
MsgBox "Error, could not find Student."
Exit Sub
End If
'now loop forwards to find first date and second date - store column naumbers
'adjust these limits where necessary - can make dynamic
For i = 4 To 13
If wsS1.Cells(2, i).Value = lDayOne Then
lColOne = i
End If
If wsS1.Cells(2, i).Value = lDayTwo Then
lColTwo = i
Exit For
End If
Next i
'now merge the range
wsS1.Range(wsS1.Cells(rSearch.Row, lColOne), wsS1.Cells(rSearch.Row, lColTwo)).Merge
'set the vvalue
wsS1.Cells(rSearch.Row, lColOne).Value = sHello
End Sub
This is just one way to approach the problem. Hopefully this helps your understanding!
No need for a loop here - just find your value and parse the dates. Assuming your value to be found exists in Column A and your table starts in Column D, there is clear relationship between the columns which is Day(date) + 3.
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, Found As Range
Dim date_a As Long, date_b As Long
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set Found = ws.Range("A2:A" & lr).Find("Student", LookIn:=xlValues)
If Not Found Is Nothing Then
date_a = Day(Range("A1")) + 3
date_b = Day(Range("B1")) + 3
With ws.Range(ws.Cells(Found.Row, date_a), ws.Cells(Found.Row, date_b))
.Merge
.Value = ws.Range("C1")
End With
Else
MsgBox "Value 'Student' Not Found"
End If
End Sub
I've tried this:
Dim ThisRow As Long
Dim FindWhat As String
FindWhat = "Student"
Dim MyStart As Byte
Dim MyEnd As Byte
MyStart = Day(Range("A1").Value) + 3 'we add +3 because starting 1 is in the fourth column
MyEnd = Day(Range("B1").Value) + 3 'we add +3 because starting 1 is in the fourth column
Dim SearchRange As Range
Set SearchRange = Range("A3:A10") 'range of values
With Application.WorksheetFunction
'we first if the value exists with a count.
If .CountIf(SearchRange, FindWhat) > 0 Then 'it means findwhat exists
ThisRow = .Match(FindWhat, Range("A:A"), 0) 'we find row number of value
Range(Cells(ThisRow, MyStart), Cells(ThisRow, MyEnd)).Value = Range("C1").Value
Application.DisplayAlerts = False
Range(Cells(ThisRow, MyStart), Cells(ThisRow, MyEnd)).Merge
Application.DisplayAlerts = True
Else
MsgBox "Value 'Student' Not Found"
End If
End With
Note I've used worksheets function COUNTIF and MATCH. MATCH will find the position of an element in a range, so if you check the whole column, it will tell you the row number. But if it finds nothing, it will rise an error. Easy way to avoid that is, first, counting if the value exists in that range with COUNTIF, and if it does, then you can use MATCH safely
Also, note that because we are using MATCH, this function only finds first coincidence, so if your list of values in column A got duplicates, this method won't work for you!.

ActiveCell VBA bugs out and crashes Excel completely

I cannot figure out why this happens (it only happens intermittently, but always with the same function)...
I am inserting a few copied rows wherever the user happens to be, and checking if a page break is necessary between them.
I managed to recover Excel after it crashed one time, and found it stalling on a line with an ActiveCell reference. I apostrophe'd the line out, and the code continued successfully line by line to the next ActiveCell reference.
I reopened the template file with the code in it, and it worked just fine.
I know it's bad practice to use ActiveCell, but I don't know how to get around it in this case - I need to add the rows right where the user is.
Should I do something like this?
Dim R As Range
Set R = ActiveCell.Address
Will that keep the original ActiveCell address or will it dynamically update as the code runs and the ActiveCell changes?
Your help is much appreciated!
[Edit]: Code (please excuse untidiness it's in development):
Sub InsertArea()
'Dimension variables
Dim SR
Dim Rng2 As Range
Dim i, j, PB1 As Integer
Dim Crit() As String
Dim w As Worksheet
i = 2
j = 0
PB1 = 0
Set Rng = Nothing
'NEW PAGE
'Check for page height breach
'Assign PB1 to selection row
PB1 = Selection.Row
'Reset i to 1
i = 1
'Loop how many extra blank rows you want below the bottom spec on a page
Do Until i = 17
'If there's a page break above row i
If Rows(PB1).Offset(i, 0).EntireRow.PageBreak <> xlPageBreakNone Then
'Copy blank row
Range("A1000:A1006").EntireRow.Copy
Selection.EntireRow.Insert Shift:=xlDown
'Insert page break just above the new area
Rows(PB1).Offset(4, 0).PageBreak = xlPageBreakManual
Selection.Offset(7, 0).Select
i = 17
Else
'Increment i to prevent infinite loop
i = i + 1
End If
Loop
'INSERT NEW AREA
'Copy blank new area
ActiveWorkbook.Names("Temp_NewArea").RefersToRange.EntireRow.Copy
'Paste (insert) that line by shifting cell up, so target cell remains in the new blank row
BUGS HERE
ActiveCell.EntireRow.Insert Shift:=xlUp
'ASSIGN NEW AREA WITH A NEW NAME
SR = ActiveWorkbook.Names("Spec1").RefersToRange.Address
'Amend selection to Quoted Specifications
ActiveCell.Offset(2, 7).Resize(4, 1).Select
'ADD THE NEW AREA TO SPECIFIED_RANGES
'Add that specified range to string SR, comma separated
SR = SR & ":" & Range("Quote_End").Offset(-3, 1).Address
'Create/Overwrite (by default) Specified_Areas range using string SR
ActiveWorkbook.Names.Add "Specified_Ranges", "=" & SR
ActiveCell.Offset(4, -7).Activate
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
Instead of using ActiveCell throughout the code, you should immediately assign it to a variable and utilize that variable instead.
Sub InsertArea()
'Dimension variables
Dim SR
Dim Rng2 As Range
Dim i, j, PB1 As Integer
Dim Crit() As String
Dim w As Worksheet
'Then declare your cell in question
Dim myCell As Range
Set myCell = ActiveCell
This will prevent cases where the ActiveCell inadvertently changes while the code is running.
Also, within your declarations
Dim i, j, PB1 As Integer
i & j are declared as type Variant, while PB1 is declared as type Integer. While it is perfectly acceptable to declare more than one variable on a single line, these declarations must be done explicitly, such as:
Dim i As Integer, j As Integer, PB1 As Integer
- OR -
Dim i%, j%, PB1%
The % is the VB symbol for Integer, and may be used in declaring variables.
Posted as answer per OP request

For Loop statement VBA Excel 2016

Proper syntax Match and If not isblank
I need some assistance with creating a loop statement that will determine the range start and end where a particular criteria is met.
I found these statements on the web and need help to modify them to loop thru two different worksheets to update a value on 1 of the worksheets.
This one has an issue returning True or False value for the Range when I want to pass the actual named range for look up where this field = Y, then returns the value from another column. I original tried using Match and If is not blank function. But that is very limiting.
See the previous post to see what I am trying to accomplish - I know I will need to expand the code samples and probably will need help with this modification.
Sub Test3()
Dim x As Integer
Dim nName As String
Sheets("BalanceSheet").Select
nName = Range("qryDifference[[Validate Adjustment]]").Select
Debug.PrintnName
' Set numrows = number of rows of data.
NumRows = Range(nName, Range(nName).End(xlDown)).Rows.Count
' Select cell a1.
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
' Insert your code here.
MsgBox"Value found in cell " & ActiveCell.Address
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub
This is what I have so far - this is giving me and issue with
ActiveCell.Offset(4, 0).Select
nAgentNo = Range("qryDifference[[agtno]]").Value
nValidate = Range("ryDifference[[Difference]]").Value
Debug.Print nAgentNo
Debug.Print nValidate
Type mismatch error on the above.
Sub Revised_AgentAmount()
Dim myRange As Range
Dim i As Long, j As Long
Dim nAgentNo As String
Dim nValidate As Long
Sheets("BalanceSheet").Select
Set myRange = Range("qryDifference[[Validate Adjustment]]")
For i = 1 To myRange.Rows.Count
For j = 1 To myRange.Columns.Count
If myRange(i, j).Value = "Y" Then
ActiveCell.Offset(4, 0).Select
nAgentNo = Range("qryDifference[[agtno]]").Value
nValidate = Range("ryDifference[[Difference]]").Value
Debug.Print nAgentNo
Debug.Print nValidate
End If
Next j
Next i
End Sub
In your first statement you declare nName as a String then try to select it. You would need to declare it as a Range if you are going to use it as a Range object.
I found solution elsewhere with a if statement instead of the for loop.
=IF([#agtno]=B24,[#[agt_amt]],SUMPRODUCT((Balance!$B$2:$B$7=[#agtno])*(Balance!$F$2:$F$7="Y")*Balance!$E$2:$E$7)+[#[agt_amt]])

Sort Rows into new sheets based on cell value

Preamble: I'm a self taught hand at anything VB script. Most of my stuff is hodgepodged-together scripts I've found.
I need to sort rows into different sheets based on a set of cell values.
In some instances its a set of numbers which would apply, in others it's a very direct value.
See:
A cell value of 1-99 goes to a sheet titled "1-99"
A cell value of 100 goes to a sheet titled "100"
There are several ranges like that. The working iteration I have only works for the direct value.
Basically, how to I get the script to understand less than or greater than or both--for instances in which it's between sets (see: 101-199)?
Set Sorter = Sheets("Raw Data").Range("M2:M100000")
For Each cell In Sorter
If cell.Value = "100" Then
cell.EntireRow.Copy
Sheets("100").Range("C" & Rows.Count).End(xlUp).Offset(1, -2).PasteSpecial
If cell.Value = "200" Then
cell.EntireRow.Copy
Sheets("200").Range("C" & Rows.Count).End(xlUp).Offset(1, -2).PasteSpecial
End If
Next
Application.CutCopyMode = False
Thank you for any and all help.
EDIT:
Below are the ranges:
1-99
100
101-199
200
201-299
300
I've got a solution for you that should show you some good concepts in VBA.
PREP FROM YOU:
Create sheets named "1-99", "100", "101-199", "200", "201-299", "300"
Include the header rows, the code I wrote works from row 2, so if your headers take up more than that, you will simply have to modify the initialization part.
Copy this code into a module and run it.
PROCESS:
Initialize the row numbers and names of all the sheets
Loop through "Raw Data" and get the tempValue to evaluate.
Using SELECT CASE statements, decide which rows go to which sheets.
Pass some arguments into a sub that will move the data accordingly, saving space and sanity.
NOTE: I'm unsure of your column that has the value to check, It looked like "M" so that's what I'm using. If it's "A" you can change it, and let me know, I will modify the answer.
TESTED:
Sub SortValuesToSheets()
Dim lastRow As Long
Dim lastCol As Long
Dim tempValue As Double 'Using Double not knowing what kind of numbers you are evaluating
Dim lRow As Long
Dim sh1 As String, sh2 As String, sh3 As String
Dim sh4 As String, sh5 As String, sh6 As String
Dim raw As String
Dim sh1Row As Long, sh2Row As Long, sh3Row As Long
Dim sh4Row As Long, sh5Row As Long, sh6Row As Long
'INITIALIZE TARGET SHEETS
'Name the target sheets
raw = "Raw Data"
sh1 = "1-99"
sh2 = "100"
sh3 = "101-199"
sh4 = "200"
sh5 = "201-299"
sh6 = "300"
'Set the row number for each target sheet to 2, to account for headers
sh1Row = 2
sh2Row = 2
sh3Row = 2
sh4Row = 2
sh5Row = 2
sh6Row = 2
lastRow = Sheets(raw).Cells(Rows.Count, "A").End(xlUp).row 'Get the last Row
lastCol = Sheets(raw).Cells(2, Columns.Count).End(xlToLeft).Column 'and column
'BEGIN LOOP THROUGH RAW DATA
For lRow = 2 To lastRow
tempValue = CDbl(Sheets(raw).Cells(lRow, "M").Value) 'set TempValue to SEARCH COLUMN
Select Case tempValue
Case Is < 1
MsgBox ("Out of Range, Under 1")
Case 1 To 99
Call CopyTempRow(lRow, sh1, sh1Row, lastCol)
sh1Row = sh1Row + 1
Case 100
Call CopyTempRow(lRow, sh2, sh2Row, lastCol)
sh2Row = sh2Row + 1
Case 101 - 199
Call CopyTempRow(lRow, sh3, sh3Row, lastCol)
sh3Row = sh3Row + 1
Case 200
Call CopyTempRow(lRow, sh4, sh4Row, lastCol)
sh4Row = sh4Row + 1
Case 201 - 299
Call CopyTempRow(lRow, sh5, sh5Row, lastCol)
sh5Row = sh5Row + 1
Case 300
Call CopyTempRow(lRow, sh6, sh6Row, lastCol)
sh6Row = sh6Row + 1
Case Is > 300
MsgBox ("Out of Range, Over 300")
End Select
Next lRow
End Sub
This is the subroutine that will copy the entire row. The reason for separating it is so that we don't have to re-write for each case with the slight variations. You wouldn't want to see this loop 6 times with only one number being changed each time. If you have to change it, you change it here, once, and call it whenever you need.
Sub CopyTempRow(row As Long, target As String, tRow As Long, lastCol As Long)
For lCol = 1 To lastCol
Sheets(target).Cells(tRow, lCol) = Sheets("Raw Data").Cells(row, lCol)
Next lCol
End Sub
Untested:
Dim v, s
Set Sorter = Sheets("Raw Data").Range("M2:M100000")
For Each cell In Sorter
v = cell.Value
if Len(v) > 0 And Isnumeric(v) Then
If v>1 and v<=99 Then
s = "1-99"
Elseif v = 100 Then
s = "100"
Else
s = ""
End If
If s<>"" Then
Sheets(s).Range("C" & Rows.Count).End(xlUp).Offset(1,0).Entirerow.Value = _
c.entirerow.Value
End if
End if
Next

Deleting entire row whose column contains a 0, Excel 2007 VBA

UPDATE:
Alright, so i used the following code and it does what i need it to do, i.e check if the value is 0 and if its is, then delete the entire row. However i want to do this to multiple worksheets inside one workbook, one at a time. What the following code is doing is that it removes the zeros only from the current spreadsheet which is active by default when you open excel through the VBA script. here the working zero removal code:
Dim wsDCCTabA As Excel.Worksheet
Dim wsTempGtoS As Excel.Worksheet
Set wsDCCTabA = wbDCC.Worksheets("Login")
Set wsTempGtoS = wbCalc.Worksheets("All_TemporaryDifferences")
Dim LastRow As Long, n As Long
LastRow = wsTempGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If Cells(n, 5).Value = 0 Then
Cells(n, 5).EntireRow.Delete
End If
Next
What am i doing wrong? when i do the same thing for another worksheet inside the same workbook it doesnt do anything. I am using the following code to remove zeros from anohter worksheet:
Set wsPermGtoS = wbCalc.Worksheets("All_PermanentDifferences")
'delete rows with 0 description
Dim LastRow As Long, n As Long
LastRow = wsPermGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If Cells(n, 5).Value = 0 Then
Cells(n, 5).EntireRow.Delete
End If
Next
Any thoughts? or another way of doing the same thing?
ORIGINAL QUESTION:
I want to delete all the rows which have a zero in a particular column. I am using the following code but nothing seems to happen:
CurrRow = (Range("E65536").End(xlUp).Row)
For Count = StartRow To CurrRow
If wsDCCTabA.Range("E" & Count).Value = "0" Then
wsDCCTabA.Rows(Count).Delete
End If
Next
StartRow contains the starting row value
CurrRow contains the row value of the last used row
See if this helps:
Sub DelSomeRows()
Dim colNo As Long: colNo = 5 ' hardcoded to look in col 5
Dim ws As Worksheet: Set ws = ActiveSheet ' on the active sheet
Dim rgCol As Range
Set rgCol = ws.Columns(colNo) ' full col range (huge)
Set rgCol = Application.Intersect(ws.UsedRange, rgCol) ' shrink to nec size
Dim rgZeroCells As Range ' range to hold all the "0" cells (union of disjoint cells)
Dim rgCell As Range ' single cell to iterate
For Each rgCell In rgCol.Cells
If Not IsError(rgCell) Then
If rgCell.Value = "0" Then
If rgZeroCells Is Nothing Then
Set rgZeroCells = rgCell ' found 1st one, assign
Else
Set rgZeroCells = Union(rgZeroCells, rgCell) ' found another, append
End If
End If
End If
Next rgCell
If Not rgZeroCells Is Nothing Then
rgZeroCells.EntireRow.Delete ' deletes all the target rows at once
End If
End Sub
Once you delete a row, u need to minus the "Count" variable
CurrRow = (Range("E65536").End(xlUp).Row)
For Count = StartRow To CurrRow
If wsDCCTabA.Range("E" & Count).Value = "0" Then
wsDCCTabA.Rows(Count).Delete
' Add this line:
Count = Count - 1
End If
Next
I got it. For future reference, i used
ActiveWorkbook.Sheets("All_temporaryDifferences").Activate
and
ActiveWorkbook.Sheets("All_Permanentdifferences").Activate
You don't need to use ActiveWorkbook.Sheets("All_temporaryDifferences").Activate. In fact if the ActiveWorkbook is different from wbCalc you would get an error.
Your real problem is that you are using an unqualified reference to Cells(n, 5).Value. Unqualified means that you aren't specifying which sheet to use so it defaults to the active sheet. That may work sometimes but it is poor code. In your case it didn't work.
Instead you should always use qualified references. wsTempGtoS.Cells(n, 5).Value is a qualified reference. wsTempGtoS specifies which worksheet you want so VBA is not left guessing.
Dim LastRow As Long, n As Long
LastRow = wsTempGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If wsTempGtoS.Cells(n, 5).Value = 0 Then
wsTempGtoS.Cells(n, 5).EntireRow.Delete
End If
Next
This: CurrRow = (Range("E65536").End(xlUp).Row) is also an unqualified reference. Instead it should be CurrRow = wsDCCTabA.Range("E65536").End(xlUp).Row.

Resources