I have a macro that puts 0 instead of blank rows there are more than 65000 of them everything works fine but problem is macro stops at line 62000 even if there is data on a next rows. Here is the code:
Sub QuickCull()
On Error Resume Next
Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
Columns("b").SpecialCells(xlBlanks).EntireRow.Delete
Columns("d").SpecialCells(xlBlanks).EntireRow.Delete
Dim col As Range
Set col = Cells(Rows.Count, "E").End(xlUp)
Dim r As Range
Set r = Range("E2", col).Resize(, 4)
Dim cell As Range
For Each cell In r
If cell.Value = "" Then
cell.Value = 0
Else
cell.Value = 1
End If
Next cell
Cells("J1").Activate
End Sub
It seems to me problem is with ranges but not sure at all. What could cause this?
The Range.Cells property does not accept the same style of cell address references that a Range object does.
Cells("J1").Activate
'should be,
Range("J1").Activate
If columns E:H are having their values changed to 1 and their blanks changed to 0 then you can continue with the Range.SpecialCells method using xlCellTypeBlanks and xlCellTypeConstants.
Sub QuickCull()
Dim col As Range, r As Range
With Worksheets("data") '<~~ you should know ehat worksheet you are on!
On Error Resume Next
.Columns("a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns("b").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns("d").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set col = .Cells(Rows.Count, "E").End(xlUp)
Set r = .Range("E2", col).Resize(col.Row - 1, 4)
r.SpecialCells(xlCellTypeConstants) = 1
r.SpecialCells(xlCellTypeBlanks) = 0
.Range("J1").Activate '<~~ or .Cells(4, "J").Activate
End With
End Sub
Related
This is a code that goes through the cells in column B in sheet2. If it finds a value that is not a date in column B, then it copies it, pastes it another sheet called 'errors' and then deletes that row from Sheet2. Whenever I try to run this, however, I get a 'Compile Error: Sub or function not defined'. I saw some other posts on this, but nothing mentioned there seemed to work for me.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheet("Errors").CountA("A1:A100")
For Each i In Worksheet("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheet("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
There are a few other errors/changes that could be made within the script
Add s to Worksheet
Use Option Explicit at top of code
Application.WorksheetFunction.CountA
Add range as argument to Counta i.e. Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Ensure correct ranges being worked with by wrapping in With Worksheets("Sheet2")
Determine last row by coming up from bottom of sheet with .Cells(.Rows.Count, "A").End(xlUp).Row, or you could end up looping to bottom of sheet
Correct syntax for delete line: i.EntireRow.Delete
You can put copy paste on one line: .Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
Be wary of using End(xlToRight) in cases of potentially ending up at far right of sheet.
Optimize code by switching some things off e.g. prevent repaint by switching off screen-updating during looping
Gather ranges to delete with Union and delete in 1 go or loop backwards to delete
VBA:
Option Explicit
Public Sub removeerrors()
Dim i As Range, x As Double, loopRange As Range, lastRow As Long, unionRng As Range
x = Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Application.ScreenUpdating = False
With Worksheets("Sheet2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set loopRange = .Range("A2:A" & lastRow)
If lastRow = 1 Then Exit Sub
For Each i In loopRange
If Not IsDate(i.Offset(0, 1)) Then
.Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, i)
Else
Set unionRng = i
End If
End If
Next i
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
You just need to change Worksheet to Worksheets with 's' at the end.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
For Each i In Worksheets("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheets("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
use fully qualified range references
loop backwards when deleting rows
update target sheet pasting row index
as follows
Option Explicit
Sub removeerrors()
Dim iRow As Long
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
With Worksheets("Sheet2") ' referecne "Sheet2" sheet
With .Range(.Range("A2"), .Range("A2").End(xlDown)) ' reference referenced sheet range from cell A2 down to next not empty one
For iRow = .Rows.Count To 1 Step -1 ' loop reference range backwards from its last row up
If Not IsDate(.Cells(iRow, 2)) Then ' if referenced range cell in column B current row is not a date
.Range(.Cells(iRow, 1), .Cells(iRow, 1).End(xlToRight)).Copy Destination:=Worksheets("Errors").Range("A1").Offset(x, 0) ' copy referenced range current row spanning from column A to next not empty column and paste it to sheet "Errors" column A row x
x = x + 1 ' update offset
.Rows(1).EntireRow.Delete ' delete referenced range current row
End If
Next
End With
End With
End Sub
I've written code to loop through a range for a specific value. If the value equals "123" then highlight the entire row green. However, I only want it to highlight the very first two matches it finds and stop there. Many thanks.
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
Sheets("XYZ").Select
Set rng = Range("L2:L10000")
For Each cell In rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
End If
Next
End Sub
It's better if you avoid using Select and other relatives, instead use referenced Objects, Sheets and Ranges.
Also, you can search for the last row with data in Column L instead of just looping through row 10000.
Option Explicit
Sub Macro3()
Dim Rng As Range, cell As Range
Dim counter As Integer, LastRow As Long
With Sheets("XYZ")
' find last row at Column "L"
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
Set Rng = .Range("L2:L" & LastRow)
For Each cell In Rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
counter = counter + 1
End If
If counter >= 2 Then Exit For
Next
End With
End Sub
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
dim count as integer
'Set the range in column D to loop through
Sheets("XYZ").Select
Set rng = Range("L2:L10000")
For Each cell In rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
count = count + 1
End If
if count >= 2 Then exit For
Next
End Sub
Filtering lets you avoid looping through cells
Assuming row 1 has header, you can try:
Dim cell As Range
Dim counter As Integer
With Sheets("XYZ")
With .Range("L1", .Cells(.Rows.Count, "L").End(xlUp)) '<--| reference its column "L" cells from row 1 (header) down to last not empty row
.AutoFilter field:=1, Criteria1:="123" '<--| filter referenced range on its first (and only) column with "123"
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell gets filtered
For Each cell In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--| loop through filtered cells, skipping header
cell.EntireRow.Interior.ColorIndex = 4
counter = counter + 1 '<--| update counter
If counter = 2 Then Exit For '<--| exit at 2nd iteration
Next cell
End If
End With
.AutoFilterMode = False
End With
Here's your code with some addition:
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
greenrows = 0
Sheets("XYZ").Select
Set rng = Range("b2:b10000")
For Each cell In rng
If cell.Value = "123" Then
If greenrows = 2 Then Exit Sub
cell.EntireRow.Interior.ColorIndex = 4
greenrows = greenrows + 1
End If
Next
End Sub
I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells.
The macro needs to recognize which cells are merged and which are not, so, I have two options:
If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.
So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what.
With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?
Code as is now:
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.count).End(xlUp).row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
rng.Select
For Each cell In rng
If cell.MergeCells Then
'Code for merged cells
Else
'Code to use for single cells
End If
Next cell
End With
ExitProgram:
Exit Sub
End Sub
Option Explicit
Sub CopyUUID()
Const UUID As Long = 31 'col AE
Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long
With ActiveSheet
kCol = -25 'col F
lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row
For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))
isM = cel.Offset(0, kCol).MergeCells
copyID = isM And Len(cel.Offset(0, kCol)) = 0
copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))
If copyID Then cel = cel.Offset(-1)
Next
End With
End Sub
Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
' Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
' rng.Select
For Each c In rng
If c.MergeCells Then
'Code for merged cells
c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
Else
'Code to use for single cells
If c.Formula = c.Offset(-1, 0).Formula Then
c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
End If
End If
Next c
End With
ExitProgram:
Exit Sub
End Sub
When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.
I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.
Hope this helps
I adopt a simple approach to this problem as illustrated through steps taken by me.
sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.
If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.
Program code is as follows:
'Without column deletion:
Sub UnMergeRanges()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
End Sub
'With coumn deletion
Sub UnMergeRangesB()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
End Sub
I'm trying to add a unit of 1 to many cells in a range. Below is where I'm at and I keep getting a type mismatch error:
Dim r As Range, cell As Range
Set r = Range("D2:E1000")
For Each cell In r
If cell.Value > 0 Then
cell.Value = cell.Value + 1
End If
Next
Here's another way
Sub Sandwich()
Dim rTemp As Range
Dim rTarget As Range
Dim sNumFmt As String
'Define the ranges
Set rTemp = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0)
Set rTarget = Sheet2.Range("D2:E1000")
'store a temporary value and the current number format
rTemp.Value = 1
sNumFmt = rTarget.Cells(1).NumberFormat
'copy and paste special-add
rTemp.Copy
rTarget.PasteSpecial , xlPasteSpecialOperationAdd
'get rid of the temp and reapply the format
rTemp.ClearContents
rTarget.NumberFormat = sNumFmt
End Sub
How about:
Sub marine()
Dim r As Range, cell As Range
Set r = Range("D2:E1000")
For Each cell In r
If IsNumeric(cell.Value) Then
If cell.Value > 0 Then
cell.Value = cell.Value + 1
End If
Else
MsgBox "Cell " & cell.Address(0, 0) & " does not have a number"
Exit Sub
End If
Next
End Sub
Stopping at OK, I'm trying to add a unit of "1" to many cells in a range. the easiest way is often without VBA or code. Just insert 1 somewhere on the spreadsheet, copy that cell, select the range of interest and Paste Special with Operation Add. The 1 can then be deleted.
Dim r As Range, cell As Range
Set r = Range("D2:E1000")
For Each cell In r
If cell > 0 Then
cell.Value = cell.Value + 1
End If
Next
Is Working for me , perhaps you want IF cell = 0 ???
Waiting for your comments to see if i anwsered your question.
I need to find the first blank row in a workbook and write information to (row, 1) and (row, 2). I think I'm currently pretty stuck...
Function WriteToMaster(num, path) As Boolean
'Declare variables
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim infoLoc As Integer
Set xlApp = New Excel.Application
Set wb = xlApp.Workbooks.Open("PATH OF THE DOC")
Set ws = wb.Worksheets("Sheet1")
'Loop through cells, looking for an empty one, and set that to the Num
Cells(1, 1).Select
For Each Cell In ws.UsedRange.Cells
If Cell.Value = "" Then Cell = Num
MsgBox "Checking cell " & Cell & " for value."
Next
'Save, close, and quit
wb.Save
wb.Close
xlApp.Quit
'Resets the variables
Set ws = Nothing
Set wb = Nothing
Set xlApp = Nothing
Thanks so much for any help.
If you mean the row number after the last row that is used, you can find it with this:
Dim unusedRow As Long
unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
If you mean a row that happens to be blank with data after it... it gets more complicated.
Here's a function I wrote which will give you the actual row number of the first row that is blank for the provided worksheet.
Function firstBlankRow(ws As Worksheet) As Long
'returns the row # of the row after the last used row
'Or the first row with no data in it
Dim rw As Range
For Each rw In ws.UsedRange.Rows
If rw.Address = ws.Range(rw.Address).SpecialCells(xlCellTypeBlanks). _
Address Then
firstBlankRow = rw.Row
Exit For
End If
Next
If firstBlankRow = 0 Then
firstBlankRow = ws.Cells.SpecialCells(xlCellTypeLastCell). _
Offset(1, 0).Row
End If
End Function
Usage example: firstblankRow(thisworkbook.Sheets(1)) or pass any worksheet.
Edit: As ooo pointed out, this will error if there are no blank cells in your used range.
I would have done it like this. Short and sweet :)
Sub test()
Dim rngToSearch As Range
Dim FirstBlankCell As Range
Dim firstEmptyRow As Long
Set rngToSearch = Sheet1.Range("A:A")
'Check first cell isn't empty
If IsEmpty(rngToSearch.Cells(1, 1)) Then
firstEmptyRow = rngToSearch.Cells(1, 1).Row
Else
Set FirstBlankCell = rngToSearch.FindNext(After:=rngToSearch.Cells(1, 1))
If Not FirstBlankCell Is Nothing Then
firstEmptyRow = FirstBlankCell.Row
Else
'no empty cell in range searched
End If
End If
End Sub
Updated to check if first row is empty.
Edit: Update to include check if entire row is empty
Option Explicit
Sub test()
Dim rngToSearch As Range
Dim firstblankrownumber As Long
Set rngToSearch = Sheet1.Range("A1:C200")
firstblankrownumber = FirstBlankRow(rngToSearch)
Debug.Print firstblankrownumber
End Sub
Function FirstBlankRow(ByVal rngToSearch As Range, Optional activeCell As Range) As Long
Dim FirstBlankCell As Range
If activeCell Is Nothing Then Set activeCell = rngToSearch.Cells(1, 1)
'Check first cell isn't empty
If WorksheetFunction.CountA(rngToSearch.Cells(1, 1).EntireRow) = 0 Then
FirstBlankRow = rngToSearch.Cells(1, 1).Row
Else
Set FirstBlankCell = rngToSearch.FindNext(After:=activeCell)
If Not FirstBlankCell Is Nothing Then
If WorksheetFunction.CountA(FirstBlankCell.EntireRow) = 0 Then
FirstBlankRow = FirstBlankCell.Row
Else
Set activeCell = FirstBlankCell
FirstBlankRow = FirstBlankRow(rngToSearch, activeCell)
End If
Else
'no empty cell in range searched
End If
End If
End Function
Update
Inspired by Daniel's code above and the fact that this is WAY! more interesting to me now then the actual work I have to do, i created a hopefully full-proof function to find the first blank row in a sheet. Improvements welcome! Otherwise, this is going to my library :)
Hopefully others benefit as well.
Function firstBlankRow(ws As Worksheet) As Long
'returns the row # of the row after the last used row
'Or the first row with no data in it
Dim rngSearch As Range, cel As Range
With ws
Set rngSearch = .UsedRange.Columns(1).Find("") '-> does blank exist in the first column of usedRange
If Not rngSearch Is Nothing Then
Set rngSearch = .UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks)
For Each cel In rngSearch
If Application.WorksheetFunction.CountA(cel.EntireRow) = 0 Then
firstBlankRow = cel.Row
Exit For
End If
Next
Else '-> no blanks in first column of used range
If Application.WorksheetFunction.CountA(Cells(.Rows.Count, 1).EntireRow) = 0 Then '-> is the last row of the sheet blank?
'-> yeap!, then no blank rows!
MsgBox "Whoa! All rows in sheet are used. No blank rows exist!"
Else
'-> okay, blank row exists
firstBlankRow = .UsedRange.SpecialCells(xlCellTypeBlanks).Row + 1
End If
End If
End With
End Function
Original Answer
To find the first blank in a sheet, replace this part of your code:
Cells(1, 1).Select
For Each Cell In ws.UsedRange.Cells
If Cell.Value = "" Then Cell = Num
MsgBox "Checking cell " & Cell & " for value."
Next
With this code:
With ws
Dim rngBlanks As Range, cel As Range
Set rngBlanks = Intersect(.UsedRange, .Columns(1)).Find("")
If Not rngBlanks Is Nothing Then '-> make sure blank cell exists in first column of usedrange
'-> find all blank rows in column A within the used range
Set rngBlanks = Intersect(.UsedRange, .Columns(1)).SpecialCells(xlCellTypeBlanks)
For Each cel In rngBlanks '-> loop through blanks in column A
'-> do a countA on the entire row, if it's 0, there is nothing in the row
If Application.WorksheetFunction.CountA(cel.EntireRow) = 0 Then
num = cel.Row
Exit For
End If
Next
Else
num = usedRange.SpecialCells(xlCellTypeLastCell).Offset(1).Row
End If
End With
I know this is an older thread however I needed to write a function that returned the first blank row WITHIN a range. All of the code I found online actually searches the entire row (even the cells outside of the range) for a blank row. Data in ranges outside the search range was triggering a used row. This seemed to me to be a simple solution:
Function FirstBlankRow(ByVal rngToSearch As Range) As Long
Dim R As Range
Dim C As Range
Dim RowIsBlank As Boolean
For Each R In rngToSearch.Rows
RowIsBlank = True
For Each C In R.Cells
If IsEmpty(C.Value) = False Then RowIsBlank = False
Next C
If RowIsBlank Then
FirstBlankRow = R.Row
Exit For
End If
Next R
End Function
ActiveSheet.Range("A10000").End(xlup).offset(1,0).Select
very old thread but .. i was lookin for an "easier"... a smaller code
i honestly dont understand any of the answers above :D
- i´m a noob
but this should do the job. (for smaller sheets)
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Add
reads every cell in col 1 from bottom up and stops at first empty cell
intRow = 1
Do until objExcel.Cells(intRow, 1).Value = ""
intRow = intRow + 1
Loop
then you can write your info like this
objExcel.Cells(intRow, 1).Value = "first emtpy row, col 1"
objExcel.Cells(intRow, 2).Value = "first emtpy row, col 2"
etc...
and then i recognize its an vba thread ... lol
Very old thread but a simpler take :)
Sub firstBlank(c) 'as letter
MsgBox (c & Split(Range(c & ":" & c).Find("", LookIn:=xlValues).address, "$")(2))
End Sub
Sub firstBlank(c) 'as number
cLet = Split(Cells(1, c).address, "$")(1)
MsgBox (cLet & Split(Range(cLet & ":" & cLet).Find("", LookIn:=xlValues).address, "$")(2))
End Sub
Function firstBlankRow() As Long
Dim emptyCells As Boolean
For Each rowinC In Sheet7.Range("A" & currentEmptyRow & ":A5000") ' (row,col)
If rowinC.Value = "" Then
currentEmptyRow = rowinC.row
'firstBlankRow = rowinC.row 'define class variable to simplify computing complexity for other functions i.e. no need to call function again
Exit Function
End If
Next
End Function