I have a large table and the information I'm wanting to add comments to falls within Range(D11:CY148). I have two tabs - "Finish Matrix" (main) and "list" (hidden - has 2 columns).
I have two issues.
First issue - Code works to a degree, after I type my values within a cell it automatically adds comments based off info in another sheet. The problem is there is too many cells to be manually typing into and if I copy and paste the code doesn't run. I created a CommandButton and wanted it to refresh the entire table with comments depending if the cells had the values that fall within "list". I tried to create a call out to Worksheet_Change but to no avail. (I'm a beginner so it'll help if you explain)
Second issue - I'm assuming it'll get fixed with whatever suggestion that works. Occasionally after typing into a cell I would get an error. Can't remember the error name but it is one of the common ones, atm the error isn't popping up but surely it'll come back since I didn't do anything different to the code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:CX")) Is Nothing Then _
If Intersect(Target, Columns("CY")) Is Nothing Then Exit Sub
Dim lRow As Integer
lRow = Sheets("list").Range("A1").End(xlDown).Row
If Target.Value = vbNullString Then Target.ClearComments
For Each cell In Sheets("list").Range("A1:A" & lRow)
If cell.Value = Target.Value Then
Target.AddComment
Target.Comment.Text Text:=cell.Offset(0, 1).Value
End If
Next cell
End Sub
Thanks for any and all help!
You are basically missing the For Each Cell in Target part...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsMain As Worksheet, wsList As Worksheet
Dim cell As Range
Dim vCommentList As Variant
Dim i As Long, lLastRow As Long
Dim sValue As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wsMain = Target.Parent
Set Target = Intersect(Target, wsMain.Range("D11:CY148"))
If Target Is Nothing Then Exit Sub
Set wsList = wsMain.Parent.Sheets("list")
lLastRow = LastRow(1, wsList)
' Read Comment List into Variant (for speed)
vCommentList = wsList.Range("A1:B" & lLastRow)
Target.ClearComments
' This...For each Cell in Target...is what you were missing.
For Each cell In Target
sValue = cell
For i = 1 To UBound(vCommentList)
If sValue = vCommentList(i, 1) Then
AddComment cell, CStr(vCommentList(i, 2))
Exit For
End If
Next
Next
ErrHandler:
If Err.Number <> 0 Then Debug.Print Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Proper way to find last row ...
Public Function LastRow(Optional Col As Integer = 1, Optional Sheet As Excel.Worksheet) As Long
If Sheet Is Nothing Then Set Sheet = Application.ActiveSheet
LastRow = Sheet.Cells(Sheet.Rows.Count, Col).End(xlUp).Row
End Function
Add Comment Sub the allows appending is needed...
Public Sub AddComment(Target As Range, Text As String)
If Target.Count = 1 Then
If Target.Comment Is Nothing Then
Target.AddComment Text
Else
Target.Comment.Text Target.Comment.Text & vbLf & Text
End If
End If
End Sub
Untested, but this will take all the values in Range(D11:CY148) and add a comment based on a lookup from Sheet "list".
Sub testy()
Dim arr As Variant, element As Variant
Dim i As Long, j As Long, listItems As Long, rwLast As Long, clLast As Long
Dim comm As String
Dim rng As Range, cell As Range
listItems = Sheets("list").Range("A1").End(xlDown).Row
rwLast = Cells.SpecialCells(xlCellTypeLastCell).Row ' Adjust to fit your needs
clLast = Cells.SpecialCells(xlCellTypeLastCell).Column 'Idem
Set rng = Sheets("list").Range("A1:A" & listItems)
arr = Range("D11:CY148").Value
With Worksheets("Finish Matrix")
For i = 1 To rwLast - 10 'Adjust to make it more general, this is pretty rough
For j = 1 To clLast - 3 'Idem
If i = 3 Then
End If
comm = ""
For Each cell In rng
If arr(i, j) = cell.Value Then
comm = comm & Chr(13) & cell.Offset(0, 1).Value
End If
Next cell
If Not (comm = "") Then
.Cells(10, 3).Offset(i, j).ClearComments
.Cells(10, 3).Offset(i, j).AddComment
.Cells(10, 3).Offset(i, j).Comment.Text Text:=comm
End If
Next j
Next i
End With
End Sub
Related
I want to find "Ext" and "/" in a column of data and delete all the text after and including those characters
If it doesn't find those characters in my data then exit the sub
I can do them separately but I definitely over complicated it, there must be an easier way
The data column will also have blanks in so I have to avoid blank cells and check the whole range of data
Code
Sub DeleteAfterText()
Dim rngFoundCell As Range
Set rngFoundCell = Sheets("User Load").Range("E1:E3000").Find(What:="Ext")
'This is checking to see if the range contains EXT, if not it exits the sub'
If rngFoundCell Is Nothing Then 'If no cell in the range has an ' then exist sub
Exit Sub
Else
Worksheets("User Load").Range("E1000").Select 'Start from bottom'
Selection.End(xlUp).Select 'This selects the bottom to the top'
Do Until ActiveCell.Value = "Phone Number" 'This does the change until it reaches the header name'
If ActiveCell.Value = "" Then 'If the cell is blank it skips it as there is no action after the then'
Else
ActiveCell = Split(ActiveCell.Value, "Ext")(0)
'ActiveCell = Split(ActiveCell.Value, "/")(0)
End If
ActiveCell.Offset(-1, 0).Select
Loop
End If
End Sub
Sub DeleteAfterText2()
Dim rngFoundCell As Range
Set rngFoundCell = Sheets("User Load").Range("E1:E3000").Find(What:="/")
'This is checking to see if the range contains EXT, if not it exits the sub'
If rngFoundCell Is Nothing Then 'If no cell in the range has an ' then exist sub
Exit Sub
Else
Worksheets("User Load").Range("E1000").Select 'Start from bottom'
Selection.End(xlUp).Select 'This selects the bottom to the top'
Do Until ActiveCell.Value = "Phone Number" 'This does the change until it reaches the header name'
If ActiveCell.Value = "" Then 'If the cell is blank it skips it as there is no action after the then'
Else
ActiveCell = Split(ActiveCell.Value, "/")(0)
End If
ActiveCell.Offset(-1, 0).Select
Loop
End If
End Sub
This code should work. It is simple to read and easy to understand.
Option Explicit
'The calling Sub
Sub main()
DeleteTextFromColumn ActiveSheet.Range("E1:E3000")
End Sub
Sub DeleteTextFromColumn(ByRef inRange As Range)
Dim cCell As Range
Dim intPos1 As Integer
Dim intPos2 As Integer
Dim strTemp As String
Dim strOut As String
'You can specify which column if more than one column is provided to the
' subroutine. Ex: Range("E1:F3000")
For Each cCell In inRange.Columns(1).Cells
strTemp = cCell.Value
'gets the position of "ext" (case insensitive)
intPos1 = InStr(LCase(strTemp), "ext")
'gets the position of "/"
intPos2 = InStr(strTemp, "/")
strOut = strTemp
If intPos1 > 1 Then
strOut = Mid(strTemp, 1, intPos1 - 1)
ElseIf intPos2 > 1 Then
strOut = Mid(strTemp, 1, intPos2 - 1)
End If
'Outputs the results
cCell.Value = strOut
Next
End Sub
It's best to break out repeated code into a sub which has parameters for the variable parts of the operation.
You can do something like this:
Sub Tester()
Dim theRange As Range
Set theRange = Sheets("User Load").Range("E1:E3000")
RemoveTextAfter theRange, "Ext"
RemoveTextAfter theRange, "/"
End Sub
Sub RemoveTextAfter(rng As Range, findWhat As String)
Dim f As Range
If Len(findWhat) = 0 Then Exit Sub
Set f = rng.Find(What:="Ext", lookat:=xlPart)
Do While Not f Is Nothing
f.Value = Split(f.Value, findWhat)(0)
Set f = rng.Find(What:="Ext", lookat:=xlPart)
Loop
End Sub
I'm going to give you two answers for the price of one. :)
At its root, the basic logic you need to figure out if a substring exists in a given string is a standard part of VBA in the InStr function. Using this, you can break out your logic to check a cell's value and (conditionally) delete the remainder of the string into a function like this:
Private Function DeleteTextAfter(ByVal contents As String, _
ByVal token As String) As String
'--- searches the given string contents and if it finds the given token
' it deletes the token and all following characters
DeleteTextAfter = contents
Dim pos1 As Long
pos1 = InStr(1, contents, token, vbTextCompare)
If pos1 > 0 Then
DeleteTextAfter = Left(contents, pos1 - 1)
End If
End Function
Notice here that using the function created above, we don't need to use Range.Find at all.
Once you have that, your top-level logic consists of setting up the range to search. In all of my code, I explicitly create objects to reference the workbook and worksheet so that I can keep things straight. In a simple example like this, it may seem like overkill, but the habit comes in handy when your code gets more involved. So I set up the range like this
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
Dim searchRange As Range
Set searchRange = userLoadWS.Range("E1:E3000")
Now the loop just goes through each cell and gets a (potentially) updated value.
Dim cell As Variant
For Each cell In searchRange
If Not cell.value = vbNullString Then
Debug.Print cell.Address & " = " & cell.value
cell.value = DeleteTextAfter(cell.value, "Ext")
cell.value = DeleteTextAfter(cell.value, "/")
End If
Next cell
So your whole solution looks like this:
Option Explicit
Public Sub TestDirectlyFromRange()
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
Dim searchRange As Range
Set searchRange = userLoadWS.Range("E1:E3000")
Dim cell As Variant
For Each cell In searchRange
If Not cell.value = vbNullString Then
Debug.Print cell.Address & " = " & cell.value
cell.value = DeleteTextAfter(cell.value, "Ext")
cell.value = DeleteTextAfter(cell.value, "/")
End If
Next cell
End Sub
Private Function DeleteTextAfter(ByVal contents As String, _
ByVal token As String) As String
'--- searches the given string contents and if it finds the given token
' it deletes the token and all following characters
DeleteTextAfter = contents
Dim pos1 As Long
pos1 = InStr(1, contents, token, vbTextCompare)
If pos1 > 0 Then
DeleteTextAfter = Left(contents, pos1 - 1)
End If
End Function
But wait, there's more!!
You're iterating over 3,000 rows of data. That can get to be slow if all those rows are filled or if you increase the number of rows to search. To speed up the search, the answer is to copy the data in the range to a memory-based array first, modify any of the data, then copy the results back. This example uses the same Function DeleteTextAfter as above and is much quicker. Use whichever one fits your situation best.
Public Sub TestRangeInArray()
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
'--- create the range and copy into a memory array
Dim searchRange As Range
Dim searchData As Variant
Set searchRange = userLoadWS.Range("E1:E3000")
searchData = searchRange.value
Dim i As Long
For i = LBound(searchData, 1) To UBound(searchData, 1)
If Not searchData(i, 1) = vbNullString Then
searchData(i, 1) = DeleteTextAfter(searchData(i, 1), "Ext")
searchData(i, 1) = DeleteTextAfter(searchData(i, 1), "/")
End If
Next i
'--- now copy the modified array back to the worksheet range
searchRange.value = searchData
End Sub
I am looking for some help in getting this code to run properly. I've gotten some help with the first part from some great people here!
Basically, the code I have now sets ranges in between cells formatted bold, as the bold represents a date. I am trying to find the individual segments in column A and copy the coresponding number in column D to another worksheet in column C. If the value is not found in the range, the row output should shift down one without filling in anything.
Here is what I have so far:
Public Sub DataBetween()
Dim thisWB As Workbook
Dim dataWS As Worksheet
Set thisWB = ThisWorkbook
Set dataWS = thisWB.sheets("FC01.RPT")
Set MoBWS = thisWB.sheets("Mix of Business")
'--- 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
'Set lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row
'--- this loop is for all the data sets...
Do
endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)
'--- this loop is to work through one data set
For i = startOfDataRow To endOfDataRow
sheets("FC01.RPT").Select
Cells.Find(What:="Individual return guest").Activate
range("D" & (ActiveCell.Row)).Select
Selection.copy
sheets("Plan").Select
range("C3").Select
ActiveSheet.Paste
Next i
startOfDataRow = endOfDataRow + 1
Loop
'Do While endOfDataRow < lastRowOfAllData
errhandler:
MsgBox "No Cells containing specified text found"
End Sub
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
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
The code keeps crashing. How can I make it so the output line shifts down one when looping though a range, no matter if it finds the value or not?
Does anyone know what do to?
Here is a snapshot of the data I am working with:
Thanks for the help!!
I noticed all your "blocks" end with some "Summe" occurrence in column A, and data begins at row 14
then I'd go this way:
Sub mm()
Dim iArea As Long
With Worksheets("FC01.RPT")
With .Range("A14", .Cells(.Rows.Count, 1).End(xlUp))
.Cells(2, 1).Value = "Summe"
.AutoFilter field:=1, Criteria1:="Summe*"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '.Offset(-1)
For iArea = 1 To .Areas.Count - 1
With .Parent.Range(.Areas(iArea).Offset(1), .Areas(iArea + 1).Offset(-1))
Worksheets("Plan").Cells(Rows.Count, "D").End(xlUp).Offset(1).Value = WorksheetFunction.SumIf(.Cells, "Individual*", .Offset(, 3))
End With
Next
End With
.Cells(2, 1).ClearContents
End With
.AutoFilterMode = False
End With
End Sub
I'd like to make a summary sheet that, if changed, changes the source sheets it is pulling from. The code I have so far aggregates all of my sheets on the summary sheet on the summary sheet's activation event. I am trying to have all of my other sheets updated on the deactivation event but it does not seem to be working. Here is the code I am working with:
Private Sub Worksheet_Deactivate()
Application.ScreenUpdating = False
Dim tabs As Variant
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", "AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = 1 To UBound(tabs)
Sheets(tabs(j)).Select
Dim rng1 As Range
Dim Stri As String
For i = 3 To ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row
Stri = ActiveSheet.Cells(i, "A")
Set rng1 = Worksheets("Summary").Range("A:A").Find(Stri, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Sheets("Summary").Range(rng1.Address).EntireRow.Copy
ActiveSheet.Range("A" & i).EntireRow.Select
Selection.Insert Shift:=xlLeft
ActiveSheet.Range("A" & i + 1).EntireRow.Select
Selection.Delete Shift:=xlUp
Else
MsgBox strSearch & " not found"
End If
Next
ActiveSheet.Range("A" & 1).Select
Next
Application.ScreenUpdating = True
End Sub
I am very new to vba and this is my first post on stackoverflow so if I missed anything just let me know.
When you assign a variant array in that manner, you will end up with a zero-based array. You need to start at j = 0. As your own code currently is, it will never access the BELD worksheet.
Dim tabs As Variant
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", "AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = 0 To UBound(tabs)
....
A more universal method would be using For j = LBound(tabs) To UBound(tabs) which does not matter whether your array is 1 or 0 based as you let each array describe its own properties through the LBound function and UBound function.
A more comprehensive rewrite of your routine would include getting rid of the .Select and .Activate methods and use direct worksheet and cell referencing in its place.
Private Sub Worksheet_Deactivate()
Dim rng1 As Range
Dim Stri As String, lr As Long, j As Long, i As Long
Dim tabs As Variant
On Error GoTo bm_Safe_exit
Application.ScreenUpdating = False
Application.EnableEvents = False
tabs = Array("BELD", "RMLD", "Pascoag", "Devens", "WBMLP", "Rowely", _
"AMP", "First Energy", "Dynegy", "APN", "MISC")
For j = LBound(tabs) To UBound(tabs)
With Sheets(tabs(j))
lr = .Cells.Find(Chr(42), After:=.Cells(1, 1), SearchDirection:=xlPrevious).Row
For i = 3 To lr
Stri = .Cells(i, "A").Value
If CBool(Len(Stri)) Then
On Error Resume Next
With Me.Range("A:A")
Set rng1 = .Find(What:=Stri, After:=.Cells(.Rows.Count), LookIn:=xlValues, LookAt:=xlWhole)
End With
On Error GoTo bm_Safe_exit
If Not rng1 Is Nothing Then
'clearing then copy/paste may be better than inserting, pasting and ultimately deleting old row
.Rows(i).Clear
rng1.EntireRow.Copy _
Destination:=.Range("A" & i)
Else
'maybe copy the data from the sheet back to the summary sheet if this occurs
MsgBox Stri & " on " & .Name & " not found on Summary"
End If
End If
Next
End With
Next
bm_Safe_exit:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Since this is in the Summary worksheet's code sheets, the use of Me can be applied to the Summary worksheet object. Once you have set rng1 to the range returned by the find, it is no longer necessary to describe the worksheet it comes from as its Range .Parent property is carried with it.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I'm not an advanced VBA programmer. I'm working on an excel macro which will allow me to select a range(using input box) to clean the data(makes consistent with mySQL schema) on worksheet. I get this file from anther team and
1.) the order of columns is not fixed
2) levels of categories(there are few columns for categories like level1 level2 etc.) can be anything between 3-10.
I want to concatenate the columns for categories(in image level 1, level 2 etc.) using | as a separator and put the values in first category column(level1) while deleting remaining columns(level 2, level 3...[level 10]).
I removed some code from the end to reduce the length here but it still makes sense:
Sub cleanData()
Dim rngMyrange As Range
Dim cell As Range
On Error Resume Next
Do
'Cleans Status column
Set rngMyrange = Application.InputBox _
(Prompt:="Select Status column", Type:=8)
On Error GoTo 0
'Is a range selected? Exit sub if not selected
If rngMyrange Is Nothing Then
End
Else
Exit Do
End If
Loop
With rngMyrange 'with the range just selected
.Replace What:="Dead", Replacement:="Inactive", SearchOrder:=xlByColumns, MatchCase:=False
'I do more replace stuff here
End With
rngMyrange.Cells(1, 1) = "Status"
Do
'Concatenates Category Columns
Set rngMyrange = Application.InputBox _
(Prompt:="Select category columns", Type:=8)
On Error GoTo 0
'Is a range selected? Exit sub if not selected
If rngMyrange Is Nothing Then
End
Else
Exit Do
End If
Loop
With rngMyrange 'with the range just selected
'Need to concatenate the selected columns(row wise)
End With
rngMyrange.Cells(1, 1) = "Categories"
End Sub
Please do not suggest a UDF, I want to do this with macro. I must do this on files before importing them on SQL database, so a macro will be handy. Please ask if I failed to mention anything else.
EDIT: Image attached for illustration
UPDATE:
I now have a working code with help from vaskov17 on mrexcel but it does not delete the columns from where the levels are picked-level 2, level 3...etc. to shift next columns to left and the major challenge for me is to implement that code in my existing macro using range type instead of long type. I do not want to enter start column and finish column separately, instead I should be able to select range like in my original macro. Code for that macro is below, please help me:
Sub Main()
Dim start As Long
Dim finish As Long
Dim c As Long
Dim r As Long
Dim txt As String
start = InputBox("Enter start column:")
finish = InputBox("Enter ending column:")
For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For c = start To finish
If Cells(r, c).Text <> "" Then
txt = txt & Cells(r, c).Text & "|"
Cells(r, c).Clear
End If
Next
If Right(txt, 1) = "|" Then
txt = Left(txt, Len(txt) - 1)
End If
Cells(r, start) = txt
txt = ""
Next
End Sub
I have removed the inputbox for selection of the category columns. Since they are always named Level x»y it makes it easier to find them automatically. That's why added a FindColumns() Sub to your code. It assigns the first fCol and last lCol Category column to global variables.
The ConcatenateColumns() concatenates cells in each row using "|" as separator.
The DeleteColumns() deletes the other columns
Cells(1, fCol).Value = "Category renames Level 1 to Category and Columns.AutoFit resizes all columns widths to fit the text.
Code:
Option Explicit
Dim fCol As Long, lCol As Long
Sub cleanData()
Dim rngMyrange As Range
Dim cell As Range
On Error Resume Next
Do
'Cleans Status column
Set rngMyrange = Application.InputBox _
(Prompt:="Select Status column", Type:=8)
On Error GoTo 0
'Is a range selected? Exit sub if not selected
If rngMyrange Is Nothing Then
End
Else
Exit Do
End If
Loop
With rngMyrange 'with the range just selected
.Replace What:="Dead", Replacement:="Inactive", SearchOrder:=xlByColumns, MatchCase:=False
'I do more replace stuff here
End With
rngMyrange.Cells(1, 1) = "Status"
' Concatenate Category Columns
FindColumns
ConcatenateColumns
DeleteColumns
Cells(1, fCol).Value = "Category"
Columns.AutoFit
End Sub
Private Sub FindColumns()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim i As Long, j As Long
For i = 1 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
If StrComp(ws.Cells(1, i).Text, "Level 1", vbTextCompare) = 0 Then
For j = i To ws.Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(1, ws.Cells(1, j).Text, "Level", vbTextCompare) Then
lCol = j
End If
Next j
fCol = i
Exit Sub
End If
Next i
End Sub
Private Sub ConcatenateColumns()
Dim rng As Range
Dim i As Long, j As Long
For i = 2 To Cells(Rows.Count, fCol).End(xlUp).Row
Set rng = Cells(i, fCol)
For j = fCol + 1 To lCol
rng = rng & "|" & Cells(i, j)
Next j
rng = "|" & rng & "|"
Set rng = Nothing
Next i
End Sub
Private Sub DeleteColumns()
Dim i As Long
For i = lCol To fCol + 1 Step -1
Columns(i).Delete Shift:=xlToLeft
Next i
End Sub
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