.End(xlDown) selecting last nonblank cell incorrectly - vba

Writing VBA code to copy a dynamic range to a new worksheet. The code is supposed to first define a range which is the range to be copied. It does this by starting in the upper left hand corner of where the range will begin, then using Range.End(xlDown) to find the last entry. The offset then finds the bottom right hand corner of the range, and the range is set to span from the upper left hand corner to the lower right hand corner. That's how it is supposed to work, and how it does work for a verbatim sub, where the only changes are in the variable names for clarity.
Here's where it goes south. The Range.End(xlDown) is indicating that the last non-blank cell in the column is the very, very bottom cell on the worksheet (Like row 40,000 something). This is clearly not true, as the last non-blank cell is three rows down from the range I am looking at. Thus, rather than getting a 4x5 size range, I get one that spans nearly the entire height of the sheet. I have also tried clearing all the formatting of the column in case something was lingering, but to no avail. The code is below.
Sub Copy_Starters_ToMaster()
Dim MasterIO As Worksheet, IOws As Worksheet
Set MasterIO = Worksheets("Master IO Worksheet")
Set IOws = Worksheets("IO Worksheet")
'Sets a range to cover all VFDs entered for an enclosure.
Dim EnclosureStarters As Range, BottomLine As Range
Set BottomLine = IOws.Range("$Z$6").End(xlDown).Offset(0, 3)
Set EnclosureStarters = IOws.Range("$Z$6", BottomLine)
'Finds first blank line in Master VFD table
Dim myBlankLine As Range
Set myBlankLine = MasterIO.Range("$AB$6")
Do While myBlankLine <> vbNullString
Set myBlankLine = myBlankLine.Offset(1, 0)
Loop
'Copies over enclosure list of VFDs, pastes into the master at the bottom of the list.
EnclosureStarters.Copy
myBlankLine.PasteSpecial
Dim BottomInEnclosure As Range, currentStarterRange As Range, EnclosureNumber As Range
'Indicates which enclosure each VFD copied in belongs to, formats appropriately.
Set BottomInEnclosure = myBlankLine.End(xlDown)
Set currentStarterRange = Range(myBlankLine, BottomInEnclosure).Offset(0, -1)
For Each EnclosureNumber In currentStarterRange
With EnclosureNumber
.Value = Worksheets("Math Sheet").Range("$A$11").Value
.BorderAround _
ColorIndex:=1, Weight:=xlThin
.HorizontalAlignment = xlCenter
End With
Next EnclosureNumber
End Sub
Any advice on this would be much appreciated, it is endlessly frustrating. Please let me know if I need to post photos of the errors, or any further code, etc.

I think the answer here is to use xlUp and a generic lastrow formula such as:
Set BottomLine = IOws.Cells(Rows.Count, "Z").End(xlUp).Offset(0, 3)
That gives the last used cell in column Z, offset by 3

Cleaner again to use Find rather than rely on the xlUp type shortcuts, something like this (which also caters for the column being empty, which is a common error when setting ranges):
Dim rng1 As Range
Set rng1 = IOws.Range("Z:Z").Find("*", IOws.[z1], xlFormulas, , xlPrevious)
If Not rng1 Is Nothing Then Set Bottomline = rng1.Offset(0, 3)
`if rng1 is Nothing then the area searched is blank

Related

How can I test if a selection is completely within a range?

So i have found this which is similar:
VBA test if cell is in a range
but this seems to be testing (as I understand it) if the cells selected intersect the range at all. However I need to find a way to confirm if the selected range is COMPLETELY within the range so that I can restrict the macro to only work inside a specified range of cells.
here is what I've got so far....I name the selected cells as a range (sel_rng) and set them as a variable....then I name the acceptable range as a named range (okay_rng)....then (hopefully....but this is the part I'm still unclear how to pull off) if "sel_rng" lies completely within "okay_rng" I want to grab "sel_rng" and merge it, otherwise throw up an error"
Sub Merge_Cells()
'
' Merge_Cells Macro
Dim selcells As Range
Selection.Name = "sel_rng"
selcells = Range("sel_rng")
Dim okayrng As Integer
okayrng = Range("itemrows").Value + 28
ActiveSheet.Range("C29:C" & okayrng).Select
Selection.Name = "okay_rng"
Range("sel_rng").Select
Selection.Merge
Thoughts anyone?
The intersection of the two ranges will determine if one range is completely within another range.
dim rng1 as range, rng2 as range
set rng1 = range("b2:c3")
set rng2 = range("a1:d4")
'if rng1 is completely within rng2, the intersection's address will be the same as rng1's address
if application.intersect(rng1, rng2).address = rng1.address then
debug.print rng1.address(0, 0) & " is within " & rng2.address(0, 0)
end if
btw, there is the possibility that the intersect could be nothing. You should add error handling for that.

Select cells between bold cells using a loop

I am working with data where the only consistency is the layout and the bold headings to distinguish between a new date.
I am trying to find the cells in between these cells in bold, find the value "Individual" (in column A) in the selected rows, then sum the values of the given rows in column D (as there can be more then 1 row with "Individual"), and copy this new value to a different cell.
Since the cells between the bold is one date, if the value is not there, the output cell needs to shift down one without filling in anything.
Here is what I have so far:
Sub SelectBetween()
Dim findrow As Long, findrow2 As Long
findrow = range("A:A").Find("test1", range("A1")).Row
findrow2 = range("A:A").Find("test2", range("A" & findrow)).Row
range("A" & findrow + 1 & ":A" & findrow2 - 1).Select
Selection.Find("Individual").Activate
range("D" & (ActiveCell.Row)).Select
Selection.copy
sheets("Mix of Business").Select
range("C4").Select
ActiveSheet.Paste
Exit Sub
errhandler:
MsgBox "No Cells containing specified text found"
End Sub
How can I loop through the data and each time it loops through a range, no matter if it finds the value (e.g. individual) or not, shifts down one row on the output cell? Also, how can I change the findrow to be a format (Bold) rather then a value?
Here is some data for reference:
This is what I am trying to get it to look like:
So you have a good start to trying to work through your data. I have a few tips to share that can hopefully help get you closer. (And please come back and ask more questions as you work through it!)
First and foremost, try to avoid using Select or Activate in your code. When you look at a recorded macro, I know that's all you see. BUT that is a recording of your keystrokes and mouseclicks (selecting and activating). You can access the data in a cell or a range without it (see my example below).
In order to approach your data, your first issue is to figure out where your data set starts (which row) and where it ends. Generally, your data is between cells with BOLD data. The exception is the last data set, which just has a many blank rows (until the end of the column). So I've created a function that starts at a given row and checks each row below it to find either a BOLD cell or the end of the data.
Private Function EndRowOfDataSet(ByRef ws As Worksheet, _
ByVal startRow As Long, _
Optional maxRowsInDataSet As Long = 50) As Long
'--- checks each row below the starting row for either a BOLD cell
' or, if no BOLD cells are detected, returns the last row of data
Dim checkCell As Range
Set checkCell = ws.Cells(startRow, 1) 'assumes column "A"
Dim i As Long
For i = startRow To maxRowsInDataSet
If ws.Cells(startRow, 1).Font.Bold Then
EndRowOfDataSet = i - 1
Exit Function
End If
Next i
'--- if we make it here, we haven't found a BOLD cell, so
' find the last row of data
EndRowOfDataSet = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
End Function
To show you how to use that with your specific data, I've created a test subroutine indicating how to loop through all the different data sets:
Option Explicit
Public Sub DataBetween()
Dim thisWB As Workbook
Dim dataWS As Worksheet
Set thisWB = ThisWorkbook
Set dataWS = thisWB.Sheets("YourNameOfSheetWithData")
'--- find the first bold cell...
'Dim nextBoldCell As Range
'Set nextBoldCell = FindNextBoldInColumn(dataWS.Range("A1"))
'--- now note the start of the data and find the next bold cell
Dim startOfDataRow As Long
Dim endOfDataRow As Long
Dim lastRowOfAllData As Long
startOfDataRow = 3
lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row
'--- this loop is for all the data sets...
Loop
endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)
'--- this loop is to work through one data set
For i = startOfDataRow To endOfDataRow
'--- work through each of the data rows and copy your
' data over to the other sheet here
Next i
startOfDataRow = endOfDataRow + 1
Do While endOfDataRow < lastRowOfAllData
End Sub
Use both of those together and see if that can get you closer to a full solution.
EDIT: I should have deleted that section of code. It was from an earlier concept I had that didn't completely work. I commented out those lines (for the sake of later clarity in reading the comments). Below, I'll include the function and why it didn't completely work for this situation.
So here's the function in question:
Public Function FindNextBoldInColumn(ByRef startCell As Range, _
Optional columnNumber As Long = 1) As Range
'--- beginning at the startCell row, this function check each
' lower row in the same column and stops when it encounters
' a BOLD font setting
Dim checkCell As Range
Set checkCell = startCell
Do While Not checkCell.Font.Bold
Set checkCell = checkCell.Offset(1, 0)
If checkCell.Row = checkCell.Parent.Rows.Count Then
'--- we've reached the end of the column, so
' return nothing
Set FindNextBoldInColumn = Nothing
Exit Function
End If
Loop
Set FindNextBoldInColumn = checkCell
End Function
Now, while this function works perfectly well, the situation is DOES NOT account for is the end of the last data set. In other words, a situation like this:
The function FindNextBoldInColumn will return nothing in this case and not the end of the data. So I (should have completely) deleted that function and replaced it with EndRowOfDataSet which does exactly what you need. Sorry about that.

Range Error - Loop to increase row index vba

This is a portion of my code. In the end, I want to loop through cells, find the text in between two phrases, concatenate that, and paste it into determined columns. Once the code finds "ID", it will add a row to the paste range, and start over. (this is near the bottom).
What I can't do, is get the range in each section to cooperate. When I use 'wksSource.Range(Cells(R, 2)).Value = stringValues' it throws the error: 1004, Method range of object worksheet failed. But if I use 'wksSource.Range("B15").Value = stringValues' it is completely fine. The problem is, that isn't dynamic. I need 'R' to increase everytime the phrase "ID" is found. The columns will be constant for each section. (R,2) (R,3) etc.
I've done so much googling and I understand why that error is thrown; I just can't figure out why it's happening in this instance. Worksheet is defined... and it works with "B15", so I'm thinking the error is in the "R", but I am stuck.
Please help! (I realize this could probably be a loop all the way, and I'd love to hear advice on that if you want, but for now, I am trying to learn and it seems the best way for me to do that is one piece at a time. Increase rows with a small loop today, tackle big loops tomorrow. :))
Dim rng As Range, AllPos As Range, rngEnd As Range, rngStart As Range
Dim DeptRng As Variant, stringValues As String, cell As Range, NextRow As Variant
Dim R As Integer, lastRowCon As Integer, wksSource As Worksheet, paste As Range
Set AllPos = Range("A2:A53")
R = 2
Set wksSource = ActiveWorkbook.Sheets("Sheet1")
Set rngStart = AllPos.Find("Department Description:").Cells
If Not rngStart Is Nothing Then
Set rngEnd = AllPos.Find("Position Duties :").Cells
Set DeptRng = Range(rngStart, rngEnd.Offset(1))
For Each C In DeptRng
stringValues = stringValues & C
Next C
wksSource.Range(Cells(R, 2)).Value = stringValues
stringValues = ""
End If
.....several iterations of above here.....
Set rngStart = AllPos.Find("ID:").Cells
If Not rngStart Is Nothing Then
'Finds last row of content
lastRowCon = wksSource.Range("A1").End(xlDown).Row
'Finds first row without content
R = lastRowCon + 1
'select next empty row, Column B
End If
wksSource.Cells(R, 2).Value = stringValues
If it's a single cell, you don't need Range().
Edit: See this for further examples. If you give the Range property one parameter, it has to be the name of a Range. Cells(i,j) returns a Range object and you don't need/can't use Cells(i,j) as a name of itself. When you use Cells(i,j) it's like using ActiveSheet.Cells(i,j), btw.

Excel Shift Data down after Insert

Hopefully someone can help me out here :(
In a sequence of workbooks (never a good idea :)), a user runs a macro which copies data from Workbook1 and inserts it using Insert Shift:=xlDown in Workbook2.
The problem is this: there is taller rows and a grouped textbox below the destination, and instead of shifting these down, the macro leaves the row size large and the textbox doesn't move.
I have set the textbox group to Move and size with cells and tried CopyOrigin:=xlFormatFromLeftOrAbove but it seems to make no difference.
Can somebody help please?
Thanks
EDIT
Here is the full code: (commented out original idea, added suggestion below)
Sub MakeQuote2()
Application.ScreenUpdating = False
Dim sourceRange As Range, loopRange As Range
Dim targetRange As Range
Dim FRow As Long
Dim m As Long
Dim p As Long
m = Sheets("Workbook1").Rows.Count
FRow = Sheets("Workbook1").Range("A" & m).End(xlUp).Row
Set sourceRange = ActiveSheet.Range("A9:E" & FRow)
Set targetRange = Workbooks.Open("C:\Users\j\Documents\Trial1.xltm").Sheets("Workbook2").Range("A4")
sourceRange.Copy
Sheets("Workbook2").Rows("4:4").EntireRow.Insert 'Select
'Selection.Insert 'Shift:=xlDown
p = FRow + 5
Sheets("Workbook2").Rows("4:" & p).Copy
Sheets("Workbook2").Rows("4:4").PasteSpecial xlPasteValues
Sheets("Workbook2").Range("A2").Select
Application.CutCopyMode = False
Workbooks("Copy.xlsm").Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Thanks!
If you want below text boxes to move and size with the cells above then it does not suffice to use
.Insert Shift:=xlDown
Instead you need to use
.EntireRow.Insert
If you copy entire rows, paste will shift everything down. If your copy source has only several columns, the data shifts down but no rows format or objects shift with it. This is true in Excel, not only in VBA.
This code works for me (I changed some of the references to test it in my environment):
Set sourceRange = Sheets("Sheet2").Range("A9:E" & FRow).EntireRow '<-- Added EntireRow here.
Set targetRange = Sheets("Sheet1").Range("A4") '<-- This is never used.
sourceRange.Copy
Sheets("Sheet1").Rows("4:4").EntireRow.Insert
The only addition I made is to add EntireRow to the source range to copy. If you need only columns A:E I would suggest you insert blank rows according to FRow - 9, and then copy and paste A:E in the added rows.
Note that you are mixing up references Sheets("Workbook1"), ActiveSheet in your original code, and you never use targetRange.
Addition
As mentioned in the first note, to add blank rows before you paste only the relevant columns, you can use something like this code:
Sheets("Sheet1").Rows("4:" & FRow - 9 + 4).EntireRow.Insert
Set sourceRange = Sheets("Sheet2").Range("A9:E" & FRow)
Set targetRange = Sheets("Sheet1").Range("A4")
sourceRange.Copy
targetRange.PasteSpecial

Select & Copy Only Non Blank Cells in Excel VBA, Don't Overwrite

I cant seem to find a solution for my application after endless searching. This is what I want to do:
I have cells in one excel sheet that can contain a mixture of dates and empty cells in one column. I want to then select the cells that have only dates and then copy them to a corresponding column in another sheet. They must be pasted in exactly the same order as in the first sheet because there are titles attached to each row. I do get it right with this code:
'Dim i As Long
'For i = 5 To 25
'If Not IsEmpty(Sheets("RMDA").Range("D" & i)) Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
'Next i
However, the dates in the first sheet are being updated on a daily basis and it can be that one title has not been updated (on another day) on the first sheet because the user has not checked it yet. If I leave it blank and If I follow the same procedure then it will "overwrite" the date in the second sheet and make the cell blank, which I do not want. I hope I was clear. Can someone please help me?
Regards
You can accomplish this very easily (and with little code) utilizing Excel's built-in AutoFilter and SpecialCells methods.
With Sheets("RMDA").Range("D4:D25")
.AutoFilter 1, "<>"
Dim cel as Range
For Each cel In .SpecialCells(xlCellTypeVisible)
Sheets("Overview").Range("D" & cel.Row).Value = cel.Value
Next
.AutoFilter
End With
you could try something like. This will give you the non blanks from the range, there may be an easier way... hope it helps
Sub x()
Dim rStart As Excel.Range
Dim rBlanks As Excel.Range
Set rStart = ActiveSheet.Range("d1:d30")
Set rBlanks = rStart.SpecialCells(xlCellTypeBlanks)
Dim rFind As Excel.Range
Dim i As Integer
Dim rNonBlanks As Excel.Range
For i = 1 To rStart.Cells.Count
Set rFind = Intersect(rStart.Cells(i), rBlanks)
If Not rFind Is Nothing Then
If rNonBlanks Is Nothing Then
Set rNonBlanks = rFind
Else
Set rNonBlanks = Union(rNonBlanks, rFind)
End If
End If
Next i
End Sub
Just because a cell is blank does not mean that it is actually empty.
Based on your description of the problem I would guess that the cells are not actually empty and that is why blank cells are being copied into the second sheet.
Rather than using the "IsEmpty" function I would count the length of the cell and only copy those which have a length greater than zero
Dim i As Long
For i = 5 To 25
If Len(Trim((Sheets("RMDA").Range("A" & i)))) > 0 Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
Next i
Trim removes all spaces from the cell and then Len counts the length of the string in the cell. If this value is greater than zero it is not a blank cell and therefore should be copied.