how to iterate over all rows of a excel sheet in VBA - excel

I have this code (This code is in Access VBA which tries to read an excel file and after checking, possibly import it):
Set ExcelApp = CreateObject("Excel.application")
Set Workbook = ExcelApp.Workbooks.Open(FileName)
Set Worksheet = Workbook.Worksheets(1)
now I want to iterate over all rows of the excel worksheet. I want something such as this:
for each row in Worksheet.rows
ProcessARow(row)
next row
where
function ProcessARow(row as ???? )
' process a row
' how Should I define the function
' how can I access each cell in the row
' Is there any way that I can understand how many cell with data exist in the row
end function
My questions:
How to define the for each code that it iterate correctly on all
rows that has data?
How to define ProcessARow properly
How to get the value of each cell in the row.
How to find how many cell with data exist in the row?
Is there any way that I detect what is the data type of each cell?
edit 1
The link solves on problem :
How to define the for each code that it iterate correctly on all rows that has data?
but what about other questions?
For example, how to define ProcessARow correctly?

If you need the values in the Row, you need use the 'Value' Property and after do an cycle to get each value
for each row in Worksheet.rows
Values=row.Value
For each cell in Values
ValueCell=cell
next cell
next row

Unfortunately you questions are very broad however I believe the below sub routine can show you a few ways of achieving what you are after. In regards to what datatype each cell is more involved as it depends what data type you wish to compare it to however I have included some stuff to hopefully help.
sub hopefullyuseful()
dim ws as worksheet
dim rng as Range
dim strlc as string
dim rc as long, i as long
dim lc as long, j as long
dim celltoprocess as range
set ws = activeworkbook.sheets(activesheet.name)
strlc = ws.cells.specialcells(xlcelltypeLastCell).address
set rng = ws.range("A1:" & lc)
rc = rng.rows.count()
debug.print "Number of rows: " & rc
lc = rng.columns.count()
debug.print "Number of columns: " & lc
'
'method 1 looping through the cells'
for i = 1 to rc
for j = 1 to lc
set celltoprocess = ws.cells(i,j)
'this gives you a cell object at the coordinates of (i,j)'
'[PROCESS HERE]'
debug.print celltoprocess.address & " is celltype: " & CellType(celltoprocess)
'here you can do any processing you would like on the individual cell if needed however this is not the best method'
set celltoprocess = nothing
next j
next i
'method 2 looping through the cells using a for each loop'
for each celltoprocess in rng.cells
debug.print celltoprocess.address & " is " & CellType(celltoprocess)
next celltoprocess
'if you just need the data in the cells and not the actual cell objects'
arrOfCellData = rng.value
'to access the data'
for i = lbound(arrOfCellData,1) to ubound(arrOfCellData,1)
'i = row'
for j = lbound(arrOfCellData,2) to ubound(arrOfCellData,2)
'j = columns'
debug.print "TYPE: " & typename(arrOfCellData(i,j)) & " character count:" & len(arrOfCellData(i,j))
next j
next i
set rng=nothing
set celltoprocess = nothing
set ws = nothing
end sub
Function CellType(byref Rng as range) as string
Select Case True
Case IsEmpty(Rng)
CellType = "Blank"
Case WorksheetFunction.IsText(Rng)
CellType = "Text"
Case WorksheetFunction.IsLogical(Rng)
CellType = "Logical"
Case WorksheetFunction.IsErr(Rng)
CellType = "Error"
Case IsDate(Rng)
CellType = "Date"
Case InStr(1, Rng.Text, ":") <> 0
CellType = "Time"
Case IsNumeric(Rng)
CellType = "Value"
End Select
end function
sub processRow(byref rngRow as range)
dim c as range
'it is unclear what you want to do with the row however... if you want
'to do something to cells in the row this is how you access them
'individually
for each c in rngRow.cells
debug.print "Cell " & c.address & " is in Column " & c.column & " and Row " & c.row & " has the value of " & c.value
next c
set c = nothing
set rngRow = nothing
exit sub
if you want your other questions answered you will have to be more specific as to what you are trying to accomplish

While I like the solution offered by #krazynhazy I believe that the following solution might be slightly shorter and closer to what you asked for. Still, I'd use the CellType function offered by Krazynhazy rather than all the Iif I currently have in the below code.
Option Explicit
Sub AllNonEmptyCells()
Dim rngRow As Range
Dim rngCell As Range
Dim wksItem As Worksheet
Set wksItem = ThisWorkbook.Worksheets(1)
On Error GoTo EmptySheet
For Each rngRow In wksItem.Cells.SpecialCells(xlCellTypeConstants).EntireRow.Rows
Call ProcessARow(wksItem, rngRow.Row)
Next rngRow
Exit Sub
EmptySheet:
MsgBox "Sheet is empty." & Chr(10) & "Aborting!"
Exit Sub
End Sub
Sub ProcessARow(wksItem As Worksheet, lngRow As Long)
Dim rngCell As Range
Debug.Print "Cells to process in row " & lngRow & ": " & wksItem.Range(wksItem.Cells(lngRow, 1), wksItem.Cells(lngRow, wksItem.Columns.Count)).SpecialCells(xlCellTypeConstants).Count
For Each rngCell In wksItem.Range(wksItem.Cells(lngRow, 1), wksItem.Cells(lngRow, wksItem.Columns.Count)).SpecialCells(xlCellTypeConstants)
Debug.Print "Row: " & lngRow, _
"Column: " & rngCell.Column, _
"Value: " & rngCell.Value2, _
IIf(Left(rngCell.Formula, 1) = "=", "Formula", IIf(IsDate(rngCell.Value), "Date", IIf(IsNumeric(rngCell.Value2), "Number", "Text")))
Next rngCell
End Sub
Note, that you have to call the sub to call a row must also include the sheet on which a row should be processed.

Related

Excel VBA Multiple Sheet Search using Data from one Column

I am trying to search for values listed in a column from multiple sheets in my excel workbook. If excel finds a match I would like it to return sheet names of the tabs that had the value.
Here is what i have done so far. I decided to start off by using one keyword to search multiple tabs, copy and paste the sheet name. The code below only paste the first resulting sheet name when there are other sheets containing the same keyword. I would like to know how i can pull the other sheet names that contain the same keyword.
I would also like to know how i can set up the keyword to use information in Column A of the Field List.
Sub FinalAppendVar()
Dim ws As Worksheet
Dim arr() As String
Keyword = "adj_veh_smart_tech_disc"
Totalsheets = Worksheets.Count
For i = 1 To Totalsheets
If Worksheets(i).Name <> "Main" Or InStr(1, Worksheets(i).Name, " Checks") Or Worksheets(i).Name
<>_ "Field Lists" Then
lastrow = Worksheets(i).Cells(Rows.Count, 4).End(xlUp).Row
For j = 2 To lastrow
If Worksheets(i).Cells(1, 3).Value = Keyword Then
Worksheets("Field Lists").Activate
lastrow = Worksheets("Field Lists").Cells(Rows.Count, 4).End(xlUp).Row
Worksheets("Field Lists").Cells(lastrow + 1, 5).Value = Worksheets(i).Name
Worksheets("Field Lists").Cells(lastrow + 2, 5).Value = Worksheets(i).Name
End If
Next
End If
Next
End Sub
The following code should work for what you described.
A couple feedback items:
Tabbing out loops and if statements significantly improves code readability
Never reuse variable names (i.e. lastrow), it makes it hard to read and can cause issues that are difficult to find later on
Follow all Next with the loop variable (i.e. Next i), this improves readability and helps you keep track of the ends of loops
.Activate and .Select are generally never required in vba, its better to be explicit in what you are referencing
Sub FinalAppendVar()
Dim searchSheet As Excel.Worksheet
Dim pasteSheet As Excel.Worksheet
Dim keyword As String
Dim lastSearchRow As Integer
Dim lastPasteRow As Integer
' set the worksheet to paste to
Set pasteSheet = ThisWorkbook.Worksheets("Field Lists")
' set keyword to look for
keyword = "adj_veh_smart_tech_disc" '<-- manual entry
'keyword = pasteSheet.Range("A1").Value '<-- use value in cell A1 on the defined pasteSheet
' loop through all sheets in the workbook
For i = 1 To ThisWorkbook.Worksheets.Count
' set the current worksheet we are looking at
Set searchSheet = ThisWorkbook.Worksheets(i)
' check if the current sheet is one we want to search in
If searchSheet.Name <> "Main" Or InStr(1, searchSheet.Name, " Checks") Or searchSheet.Name <> "Field Lists" Then
' current worksheet is one we want to search in
' find the last row of data in column D of the current sheet
lastSearchRow = searchSheet.Cells(1048576, 4).End(xlUp).Row
' loop through all rows of the current sheet, looking for the keyword
For j = 2 To lastSearchRow
If searchSheet.Cells(j, 3).Value = keyword Then
' found the keyword in row j of column C in the current sheet
' find the last row of column D in the paste sheet
'lastPasteRow = pasteSheet.Cells(1048576, 4).End(xlUp).Row
lastPasteRow = pasteSheet.Cells(1048576, 5).End(xlUp).Row '<-- update based on OPs comment
' paste the name of the current search sheet to the last empty cell in column E
pasteSheet.Cells(lastPasteRow + 1, 5).Value = searchSheet.Name
' not sure if the next line is needed, looks like it pastes again immediately below the previous
pasteSheet.Cells(lastPasteRow + 2, 5).Value = searchSheet.Name
' to save time consider exiting the search in the current sheet since the keyword was just found
' this will move to the next sheet immediately and not loop through the rest of the rows on the current
' search sheet. This may not align with the usecase so it is currently commented out.
'Exit For '<--uncomment this to move to the next sheet after finding the first instance of the keyword
Else
' the keyoword was not in row j of column C
' do nothing
End If
Next j
Else
' current sheet is one we don't want to search in
' do nothing
End If
Next i
End Sub
Please try this variant (Don't worry that the code is so long - the longer the programmer thought and the more wrote, the better the program works ... usually it is):
Option Explicit
Sub collectLinks()
Const LIST_SHEET_NAME As String = "Field Lists"
Dim wsTarget As Worksheet
Dim wsEach As Worksheet
Dim keywordCell As Range
Dim sKeyword As String
Dim linkCell As Range
Dim aFound As Range
Dim aCell As Range
On Error Resume Next
Set wsTarget = ActiveWorkbook.Worksheets(LIST_SHEET_NAME)
On Error GoTo 0
If wsTarget Is Nothing Then
MsgBox "'" & LIST_SHEET_NAME & "' not exists in active workbook", vbCritical, "Wrong book or sheet name"
Exit Sub
End If
Rem Clear all previous results (from column B to end of data)
wsTarget.UsedRange.Offset(0, 1).ClearContents
Rem Repeat for each cell of column A in UsedRange:
For Each keywordCell In Application.Intersect(wsTarget.UsedRange, wsTarget.Columns("A")) ' It can be changed to "D", "AZ" or any other column
sKeyword = keywordCell.Text
If Trim(sKeyword) <> vbNullString Then
Application.StatusBar = "Processed '" & sKeyword & "'"
Set linkCell = keywordCell
For Each wsEach In ActiveWorkbook.Worksheets
If wsEach.Name <> LIST_SHEET_NAME Then
Application.StatusBar = "Processed '" & sKeyword & "' Search in '" & wsEach.Name & "'"
Set aFound = FindAll(wsEach.UsedRange, sKeyword)
If Not aFound Is Nothing Then
For Each aCell In aFound
Set linkCell = linkCell.Offset(0, 1) ' Shift to rught, to the next column
linkCell.Formula2 = "=HYPERLINK(""#" & aCell.Address(False, False, xlA1, True) & """,""" & _
aCell.Worksheet.Name & " in cell " & aCell.Address(False, False, xlA1, False) & """)"
Next aCell
End If
End If
Next wsEach
End If
Next keywordCell
Application.StatusBar = False
Rem Column width
wsTarget.UsedRange.Columns.AutoFit
End Sub
Function FindAll(SearchRange As Range, FindWhat As Variant) As Range
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
Rem If your keyword can be a part of cell then change parameter xlWhole to xlPart:
Set FoundCell = SearchRange.Find(FindWhat, LastCell, xlValues, xlWhole, xlByRows)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
You can see how it works in this demo workbook - Create Links To Keywords.xlsm
EDIT By the way, the second part of this code, the FindAll() function, is a slightly shortened version of the Chip Pearson macro. Keep this link for yourself, there are many useful things to help you in future development.

Print multiple copies of the same sheet, but replace one cell with the data from a list (range) from another sheet

I am trying to print a few months worth of time sheets. So print 20 copies of the same sheet, and change the date on one cell (cell "C1" on "Timesheets" sheet) using a list of fortnightly dates on the "Pay Periods" sheet.
Have tried multiple methods but can't get close for varying reasons...
Would be interested to learn why am getting errors or stuck on each method I have tried below.
Sub PrintAllDates()
Dim printDate As Date
Dim startDate As Date
Dim endDate As Date
startDate = Worksheets("Pay Periods").Range("A2")
endDate = Worksheets("Pay Periods").Range("A10")
For printDate = startDate To endDate
Sheets("Timesheet").Range("C1") = printDate
Sheets("Timesheet").PrintOut
Next
This works but I can't figure out how to get it to use the list.
It prints out 9 consecutive days instead, whereas my list is 9 consecutive "fortnights".
Sub PrintCopies()
Dim i As Integer
Dim VList As Variant
VList = Sheets("Pay Periods").Range("H2:H3").Value
For i = LBound(VList) To UBound(VList)
Range("C1") = VList(i)
ActiveSheet.PrintOut
Next
With the above, I get runtime error 9 "Subscript out of range" on Range("C1") = VList(i)
Sub PrintCopies()
Dim i As Date
Dim VList As Variant
VList = Array(Worksheets("Pay Periods").Range("A2:A10"))
For i = LBound(VList) To UBound(VList)
Sheets("Timesheet").Range("C1") = VList(i)
Sheets("Timesheet").PrintOut
Next
This also works, but only 1 page gets printed out.
Date also gets converted to "13 Jan 1900".
The first code does not work because it is not considering the whole range of dates; instead it takes only the value inside the first and last cell, treating them as dates. The code basically takes those dates and covers each day between them. It does not even akwnoledge the others cells between A2 and A10. This one should work:
Sub PrintAllDates()
'Declaring variables.
Dim RngDate As Range
Dim RngDates As Range
Dim RngTarget As Range
'Setting variables.
Set RngDates = Sheets("Pay Periods").Range("A2:A10")
Set RngTarget = Sheets("Timesheet").Range("C1")
'Covering each cell in RngDates.
For Each RngDate In RngDates
'Changing RngTarget.
RngTarget = RngDate.Value
'Printing RngTarget's sheet.
RngTarget.Parent.PrintOut
Next
End Sub
I've also added a feature to check if the given value is a date in this version:
Sub PrintAllDates()
'Declaring variables.
Dim RngDate As Range
Dim RngDates As Range
Dim RngTarget As Range
'Setting variables.
Set RngDates = Sheets("Pay Periods").Range("A2:A10")
Set RngTarget = Sheets("Timesheet").Range("C1")
'Covering each cell in RngDates.
For Each RngDate In RngDates
'Checking if RngDate does not contain a date value.
If Not VBA.Information.IsDate(RngDate.Value) Then
'Asking what to do in case RngDate does not contain a date value.
Select Case MsgBox("Range " & RngDate.Address(False, False) & " in sheet " & RngDate.Parent.Name & " contains the value """ & RngDate.Value & """, which is a non-date value." & vbCrLf & _
vbCrLf & _
vbCrLf & _
"Do you wish to use it and print anyway?" & vbCrLf & _
vbCrLf & _
"Press ""Yes"" to print it anyway." & vbCrLf & _
vbCrLf & _
"Press ""No"" to not print it and proceed to the next value." & vbCrLf & _
vbCrLf & _
"Press ""Cancel"" to stop the macro and print no more.", _
vbYesNoCancel, _
"Non-date value detected" _
)
'If "Cancel" is pressed, the macro is terminated.
Case Is = 2
Exit Sub
'If "Yes" is pressed, the macro goes on.
Case Is = 6
'If "No" is pressed, the macro goes to NextRngDate
Case Is = 7
GoTo NextRngDate
End Select
End If
'Changing RngTarget.
RngTarget = RngDate.Value
'Printing RngTarget's sheet.
RngTarget.Parent.PrintOut
'Checkpoint.
NextRngDate:
Next
End Sub
Your code can be something like this:
Sub PrintAllDates()
Dim listRange As Range ' Your range A2:A10 in "Pay Periods" sheet '
Dim oCurrentCell As Range ' Single cell from this range '
Dim printedSheet As Worksheet ' Target sheet - "Timesheet" '
Dim oTargetCell As Range ' C1 - target cell (to set next date from list) '
Set listRange = Worksheets("Pay Periods").Range("A2:A10")
Set printedSheet = Worksheets("Timesheet")
Set oTargetCell = printedSheet.Range("C1")
For Each oCurrentCell In listRange.Cells
oTargetCell = oCurrentCell
Rem If some cells in "Timesheet" has formulas which reffered to C1,
Rem we need recalc it before printing
printedSheet.Calculate
printedSheet.PrintOut
Next oCurrentCell
End Sub

Excel VBA: How do I add text to a blank cell in a specific column then loop to the next blank cell and add text?

I need a macro to add text to blank cells in Column A. The macro needs to skip cells that have text. The macro needs to stop looping at the end of the data set.
I am trying to use an If Else statement, but I think I'm on the wrong track. My current, non-working code is below. Thank you so much - I'm still new to VBA
Sub ElseIfi()
For i = 2 To 100
If Worksheets("RawPayrollDump").Cells(2, 1).Value = "" Then
Worksheets("RawPayrollDump").Cells(2, 1).Value = "Administration"
Else if(not(worksheets("RawPayrollDump").cells(2,1).value="")) then 'go to next cell
End If
Next
End Sub
To find the last row of data, use the End(xlUp) function.
Try this code. It replaces all empty cells in column A with Administration.
Sub ElseIfi()
Set ws = Worksheets("RawPayrollDump")
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row ' last data row
For i = 2 To lastrow ' all rows until last data row
If ws.Cells(i, 1).Value = "" Then ' column A, check if blank
ws.Cells(i, 1).Value = "Administration" ' set text
End If
Next
End Sub
There is no need to loop. Please try this code.
Sub FillBlanks()
Dim Rng As Range
With Worksheets("RawPayrollDump")
Set Rng = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
On Error Resume Next
Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
If Err Then
MsgBox "There are no blank cells" & vbCr & _
"in the specified range.", _
vbInformation, "Range " & Rng.Address(0, 0)
Else
Rng.Value = "Administration"
End If
End Sub
Replace Blanks feat. CurrentRegion
Range.CurrentRegion
Since OP asked for "... stop looping at the end of the data set. ",
I've written this CurrentRegion version.
As I understand it, the end of the data set doesn't mean that there
cannot be blank cells below the last cell containing data in column
A.
Use the 1st Sub to test the 2nd, the main Sub (replaceBlanks).
Adjust the constants including the workbook (in the 1st Sub) to fit your needs.
Criteria is declared as Variant to allow other data types not just strings.
The Code
Option Explicit
Sub testReplaceBlanks()
Const wsName As String = "RawPayrollDump"
Const FirstCellAddress As String = "A2"
Const Criteria As Variant = "Administration"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
replaceBlanks ws, FirstCellAddress, Criteria
End Sub
Sub replaceBlanks(Sheet As Worksheet, _
FirstCellAddress As String, _
Criteria As Variant)
' Define column range.
Dim ColumnRange As Range
Set ColumnRange = Intersect(Sheet.Range(FirstCellAddress).CurrentRegion, _
Sheet.Columns(Sheet.Range(FirstCellAddress) _
.Column))
' To remove the possibly included cells above the first cell:
Set ColumnRange = Sheet.Range(Range(FirstCellAddress), _
ColumnRange.Cells(ColumnRange.Cells.Count))
' Note that you can also use the addresses instead of the cell range
' objects in the previous line...
'Set ColumnRange = sheet.Range(FirstCellAddress, _
ColumnRange.Cells(ColumnRange.Cells.Count) _
.Address)
' or a mixture of them.
' Write values from column range to array.
Dim Data As Variant
If ColumnRange.Cells.Count > 1 Then
Data = ColumnRange.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = ColumnRange.Value
End If
' Modify array.
Dim i As Long, k As Long
For i = 1 To UBound(Data)
If IsEmpty(Data(i, 1)) Then Data(i, 1) = Criteria: k = k + 1
Next i
' Write modified array to column range.
' The following line is used when only the first cell is known...
'Sheet.Range(FirstCellAddress).Resize(UBound(Data)).Value = Data
' ...but since the range is known and is the same size as the array,
' the following will do:
ColumnRange.Value = Data
' Inform user.
If k > 0 Then GoSub Success Else GoSub Fail
Exit Sub
' Subroutines
Success:
MsgBox "Wrote '" & Criteria & "' to " & k & " previously " _
& "empty cell(s) in range '" & ColumnRange.Address & "'.", _
vbInformation, "Success"
Return
Fail:
MsgBox "No empty cells in range '" & ColumnRange.Address & "'.", _
vbExclamation, "Nothing Written"
Return
End Sub

VBA: Find last row in a fixed number of ranges

I tried for a few hours to search and look for a possible answer. I am about ready to give up. I haven't been able to find someone with a scenario quite like the one I am asking, maybe I overlooked it.
I want to find the last row in a specific range. The ranges are A7 to A21. I want to be able to enter input data from my form to the empty row within that range...
Here is where it gets tricky. I also have two other categories on the same sheet where I need to input data. Data may already be here, again I want to find the last row and then input data. Ranges A27:A41.
And the last category ranges A46:A66.
Hopefully someone here can help me out.
Define the ranges you use as tables in Excel on the sheet. Then in your code use:
Dim Table1 As listObject, Table2 As ListObject
With ThisWorkbook.Worksheets("Name of the sheet the tables are on")
Set Table1 = .ListObjects("Name of the table")
Set Table2 = .ListObjects("Name of the table")
End With
Dim LastRowT1 As Long, LastRowT2 As Long
LastRowT1 = 1: LastRowT2 = 1
Do Until Table1.DataBodyRange(LastRowT1, 1) = Empty
LastRowT1 = LastRowT1 + 1
Loop
Do Until Table2.DataBodyRange(LastRowT2, 1) = Empty
LastRowT2 = LastRowT2 + 1
Loop
'If you run out of space and automatically want to add an extra row add
'the following code.
If LastRowT1 > Table1.ListRows.Count Then
Table2.ListRows.Add AlwaysInsert:=True
End If
If LastRowT2 > Table2.ListRows.Count Then
Table2.ListRows.Add AlwaysInsert:=True
End If
The Value of LastRowT1 and LastRowT2 should be the row number (of the listobject) of the first empty row.
This should get you pointed in the right direction...
Sub Main()
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rFind As Range
'Set your range vars
Set r1 = Range("A7:A21")
Set r2 = Range("A27:A41")
Set r3 = Range("A46:A66")
'Find the next empty cell and display the address
On Error Resume Next
'First range
Set rFind = r1.Find("*", searchdirection:=xlPrevious).Offset(1, 0)
If Not rFind Is Nothing Then
MsgBox "First open cell in " & r1.Address & " is " & rFind.Address
Else
MsgBox "First open cell in " & r1.Address & " is " & r1.Cells(1, 1).Address
End If
'Second range
Set rFind = r2.Find("*", searchdirection:=xlPrevious).Offset(1, 0)
If Not rFind Is Nothing Then
MsgBox "First open cell in " & r2.Address & " is " & rFind.Address
Else
MsgBox "First open cell in " & r2.Address & " is " & r2.Cells(1, 1).Address
End If
'Third range
Set rFind = r3.Find("*", searchdirection:=xlPrevious).Offset(1, 0)
If Not rFind Is Nothing Then
MsgBox "First open cell in " & r3.Address & " is " & rFind.Address
Else
MsgBox "First open cell in " & r3.Address & " is " & r3.Cells(1, 1).Address
End If
End Sub
This assumes that you're filling the cells from the top down (e.g. A7 fills first, A8 is next, then A9, etc.). If that's not the case, then instead of .Find you'd need to use a loop. You'll definitely need to adapt this to you situation, especially the logic for when all the cells in your ranges fill up.
To make your request more generic (and hence scalable), you could create a function to find the first available row of any given range:
Function FindFirstOpenCell(ByVal R As Range) As Integer
Dim row, col As Integer
row = R.row
col = R.Column
FindFirstOpenCell = Cells(row + R.Rows.Count - 1, col).End(xlUp).row + 1
End Function
From here you could simply call the function over and over:
Dim row As Integer
row = FindFirstOpenCell(Range("A7:A21"))
Cells(row, 1).Value = "My Next Item"

Get start range and end range of a vertically merged cell with Excel using VBA

I need to find out the first cell and the last cell of a vertically merged cell..
Let's say I merge Cells B2 down to B50.
How can I get in VBA the start cell(=B2) and the end cell(=B50)?
Sub MergedAreaStartAndEnd()
Dim rng As Range
Dim rngStart As Range
Dim rngEnd As Range
Set rng = Range("B2")
If rng.MergeCells Then
Set rng = rng.MergeArea
Set rngStart = rng.Cells(1, 1)
Set rngEnd = rng.Cells(rng.Rows.Count, rng.Columns.Count)
MsgBox "First Cell " & rngStart.Address & vbNewLine & "Last Cell " & rngEnd.Address
Else
MsgBox "Not merged area"
End If
End Sub
Below macro goes through all sheets in a workbook and finds merged cells, unmerge them and put original value to all merged cells.
This is frequently needed for DB applications, so I wanted to share with you.
Sub BirlesenHucreleriAyirDegerleriGeriYaz()
Dim Hucre As Range
Dim Aralik
Dim icerik
Dim mySheet As Worksheet
For Each mySheet In Worksheets
mySheet.Activate
MsgBox mySheet.Name & “ yapılacak…”
For Each Hucre In mySheet.UsedRange
If Hucre.MergeCells Then
Hucre.Orientation = xlHorizontal
Aralik = Hucre.MergeArea.Address
icerik = Hucre
Hucre.MergeCells = False
Range(Aralik) = icerik
End If
Next
MsgBox mySheet.Name & " Bitti!!"
Next mySheet
End Sub
Suppose you merged B2 down to B50.
Then, start cell address will be:
MsgBox Range("B2").MergeArea.Cells(1, 1).Address
End cell address will be:
With Range("B2").MergeArea
MsgBox .Cells(.Rows.Count, .Columns.Count).Address
End With
You can put address of any cell of merged area in place of B2 in above code.
Well, assuming you know the address of one of the cells in the merged range, you could just select the offset from that range and get the row/column:
Sub GetMergedRows()
Range("A7").Select 'this assumes you know at least one cell in a merged range.
ActiveCell.Offset(-1, 0).Select
iStartRow = ActiveCell.Row + 1
Range("A7").Select
ActiveCell.Offset(1, 0).Select
iEndRow = ActiveCell.Row - 1
MsgBox iStartRow & ":" & iEndRow
End Sub
The code above will throw errors if the offset row cannot be selected (i.e. if the merged rows are A1 through whatever) so you will want to add error handling that tells the code if it can't offset up, the top rows must be 1 and if it can't go down, the bottom row must be 65,536. This code is also just one dimensional so you might want to add the x-axis as well.
If you want the cell references as strings, you can use something like this, where Location, StartCell, and EndCell are string variables.
Location = Selection.Address(False, False)
Colon = InStr(Location, ":")
If Colon <> 0 Then
StartCell = Left(Location, Colon - 1)
EndCell = Mid(Location, Colon + 1)
End If
If you want to set them as ranges, you could add this, where StartRange and EndRange are Range objects.
set StartRange = Range(StartCell)
set EndRange = Range (EndCell)
If you intend to loop through the merged cells, try this.
Sub LoopThroughMergedArea()
Dim rng As Range, c As Range
Set rng = [F5]
For Each c In rng.MergeArea
'Your code goes here
Debug.Print c.Address'<-Sample code
Next c
End Sub

Resources