Find Cell containing text in column and does NOT contain certain word in first 6 characters of string - excel

I am searching a column for cell that contains text and does not contain the word "cat" in the first 6 characters (needs to be case insensitive). This will then cut that entire row to another sheet. Cannot get the code to run without compile errors. the below code is before i try to change it. I do not know how to code it to look at the first 6 characters.
tried instr & iserror but i think my existing code just needs a small alteration which escapes me.
Sub CATDEFECTS()
UsdRws = Range("C" & Rows.Count).End(xlUp).Row
For i = UsdRws To 2 Step -1
If Range("C" & i).Value Like "<>""" And Range("c" & i).Value Like "CAT" Then
Rows(i).Cut Sheets("AWP DEFECTS").Range("A" & rows.Count).End(xlUp).Offset(1)
Rows(i).Delete
End If
Next i
End Sub

Regardless of how you decide to implement the macro, your test to see if a cell is blank is entirely redundant. You can just test if the cell meets your CAT criteria. If it does, it is definitely not blank so no need to test it.
Method 1
You can look at the first 6 characters with LEFT(Range, 6)
If Left(Range("C" & i), 6) Like "*CAT*" Then
This needs Option Compare to work (Thanks #Comintern)
Method 2
I would prefer this method. Its explicit and does not delete or shift anything inside the loop so your action statements are greatly minimized.
Sub Cat()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<--UPDATE
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("AWP DEFECTS")
Dim LR As Long, DeleteMe As Range, i As Long
LR = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
For i = 2 To LR
If InStr(Left(ws.Range("C" & i), 6), "CAT") Then
If Not DeleteMe Is Nothing Then
Set DeleteMe = Union(DeleteMe, ws.Range("C" & i))
Else
Set DeleteMe = ws.Range("C" & i)
End If
End If
Next i
Application.ScreenUpdating = False
If Not DeleteMe Is Nothing Then
LR = ps.Range("A" & ps.Rows.Count).End(xlUp).Row
DeleteMe.EntireRow.Copy ps.Range("A" & LR)
DeleteMe.EntireRow.Delete
End If
Application.ScreenUpdating = True
End Sub

If cat is within the first 6 characters then InStr will report its position being less than 5.
Sub CATDEFECTS()
dim UsdRws as long, pos as long
UsdRws = Range("C" & Rows.Count).End(xlUp).Row
For i = UsdRws To 2 Step -1
pos =instr(1, cells(i, "C").value2, "cat", vbtextcompare)
If pos > 0 and pos < 5 Then
Rows(i).Cut Sheets("AWP DEFECTS").Range("A" & rows.Count).End(xlUp).Offset(1)
Rows(i).Delete
End If
Next i
End Sub

Criteria Backup (Hide/Delete)
To enable the deletion of the rows in the Source Worksheet you have to set cDEL to True in the constants section. Adjust the other constants to fit you needs.
The Code
Option Explicit
'Option Compare Text
Sub CATDEFECTS()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' Source Constants
Const cSource As Variant = "Sheet1" ' Worksheet Name/Index
Const cCol As Variant = "C" ' Search Column Letter/Number
Const cFirstR As Long = 2 ' First Row Number
Const cChars As Long = 6 ' Number of Chars
Const cSearch As String = "CAT" ' Search String
' Target Constants
Const cTarget As Variant = "AWP DEFECTS" ' Worksheet Name/Index
Const cColTgt As Variant = "A" ' Column Letter/Number
Const cFirstRTgt As Long = 2 ' First Row Number
Const cDEL As Boolean = False ' Enable Delete (True)
' Variables
Dim rngH As Range ' Help Range
Dim rngU As Range ' Union Range
Dim vntS As Variant ' Source Array
Dim i As Long ' Source Range Row Counter
' The Criteria
' When the first "cChars" characters do not contain the case-INsensitive
' string "cSearch", the criteria is met.
' Source Worksheet
With ThisWorkbook.Worksheets(cSource)
' Calculate Last Cell in Search Column using the Find method and
' assign it to Help (Cell) Range.
Set rngH = .Columns(cCol).Find("*", , xlFormulas, _
xlWhole, xlByColumns, xlPrevious)
' Calculate Source Column Range from Help (Cell) Range.
If Not rngH Is Nothing Then ' Last Cell was found.
' Calculate Source Column Range and assign it to
' Help (Column) Range using the Resize method.
Set rngH = .Cells(cFirstR, cCol).Resize(rngH.Row - cFirstR + 1)
' Copy Help (Column) Range into 2D 1-based 1-column Source Array.
vntS = rngH
' Show hidden rows to prevent the resulting rows (the rows to be
' hidden or deleted) to appear hidden in Target Worksheet.
rngH.EntireRow.Hidden = False
Else ' Last Cell was NOT found (unlikely).
MsgBox "Empty Column '" & cCol & "'."
GoTo ProcedureExit
End If
' Loop through rows of Source Array.
For i = 1 To UBound(vntS)
' Check if current Source Array value doesn't meet Criteria.
If InStr(1, Left(vntS(i, 1), cChars), cSearch, vbTextCompare) = 0 _
Then ' "vbUseCompareOption" if "Option Compare Text"
' Note: To use the Like operator instead of the InStr function
' you have to use (uncomment) "Option Compare Text" at the beginning
' of the module for a case-INsensitive search and then outcomment
' the previous and uncomment the following line.
' If Not Left(vntS(i, 1), cChars) Like "*" & cSearch & "*" Then
Set rngH = .Cells(i + cFirstR - 1, cCol)
If Not rngU Is Nothing Then
' Union Range contains at least one range.
Set rngU = Union(rngU, rngH)
Else
' Union Range does NOT contain a range (only first time).
Set rngU = rngH
End If
End If
Next
End With
' Target Worksheet
If Not rngU Is Nothing Then ' Union Range contains at least one range.
With ThisWorkbook.Worksheets(cTarget)
' Calculate Last Cell in Search Column using the Find method and
' assign it to Help Range.
Set rngH = .Columns(cColTgt).Find("*", , xlFormulas, _
xlWhole, xlByColumns, xlPrevious)
' Calculate Last Cell from Help Range, but in column 1 ("A").
If Not rngH Is Nothing Then ' Last Cell was found.
Set rngH = .Cells(rngH.Row + 1, 1)
Else ' Last Cell was NOT found.
Set rngH = .Cells(cFirstRTgt - 1, 1)
End If
' Copy the entire Union Range to Target Worksheet starting from
' Help Range Row + 1 i.e. the first empty row (in one go).
' Note that you cannot Cut/Paste on multiple selections.
rngU.EntireRow.Copy rngH
End With
' Hide or delete the transferred rows (in one go).
If cDEL Then ' Set the constant cDEL to True to enable Delete.
rngU.EntireRow.Delete
Else ' While testing the code it is better to use Hidden.
rngU.EntireRow.Hidden = True
End If
End If
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Remarks
The use of the array did not speed up considerably.
The InStr function was a few milliseconds faster than the Like operator in my data set.
Calculating the Real Used Range and copying it into a Source Array
and then writing the data that meets the criteria from Source Array
to a Target Array and copying the Target Array to the Target
Worksheet, might be faster, and/but would additionally copy the data without formulas or formatting.

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.

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

how to merge cells with same value in one row

How do I merge cells with the same value and color in a row?
and the result should be :
I think you could try this:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, Value As Long
Dim Color As Double
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
Value = .Range("A" & i).Value
Color = .Range("A" & i).Interior.Color
If .Range("A" & i - 1).Value = Value And .Range("A" & i - 1).Interior.Color = Color Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
Copy Consecutive to One
Adjust the values in the constants section to fit your needs.
The image looks like you want all this to happen in the same column
of the same worksheet, which is adjusted in the constants section.
Before writing to Target Column (cTgtCol), the code will clear its
contents. Be careful not to lose data.
Colors are applied using a loop, which will slow down the fast array approach of copying the data.
The Code
Sub CopyConsecutiveToOne()
' Source
Const cSource As Variant = "Sheet1" ' Worksheet Name/Index
Const cSrcCol As Variant = "A" ' Column Letter/Number
Const cSrcFR As Long = 1 ' Column First Row Number
' Target
Const cTarget As Variant = "Sheet1" ' Worksheet Name/Index
Const cTgtCol As Variant = "A" ' Column Letter/Number
Const cTgtFR As Long = 1 ' Column First Row Number
Dim rng As Range ' Source Column Last Used Cell Range,
' Source Column Range, Target Column Range
Dim vntS As Variant ' Source Array
Dim vntT As Variant ' Target Array
Dim vntC As Variant ' Color Array
Dim i As Long ' Source Range/Array Row/Element Counter
Dim k As Long ' Target/Color Array Element Counter
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'On Error GoTo ProcedureExit
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource).Columns(cSrcCol)
' Calculate Source Column Last Used Cell Range.
Set rng = .Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious)
' Check if data in Source Column.
If Not rng Is Nothing Then ' Data found.
' Calculate Source Range.
Set rng = .Range(.Cells(cSrcFR), .Cells(rng.Row))
' Copy values from Source Range to Source Array.
vntS = rng
Else ' Data Not Found.
With .Cells(1)
MsgBox "No Data in column '" & .Split(.Address, "$")(1) & "'."
GoTo ProcedureExit
End With
End If
End With
' In Arrays
' Count the number of elements in Target/Color Array.
k = 1 ' The first element will be included before the loop.
' Loop through elements of Source Array.
For i = 2 To UBound(vntS)
' Check if current value is different then the previous one.
If vntS(i, 1) <> vntS(i - 1, 1) Then
' Count element of Target/Color Array.
k = k + 1
End If
Next
' Write to Target/Color Arrays
' Resize Target/Color Arrays.
ReDim vntT(1 To k, 1 To 1)
ReDim vntC(1 To k, 1 To 1)
' Reset Counter
k = 1 ' The first element will be included before the loop.
' Write first value from Source Array to Target Array.
vntT(1, 1) = vntS(1, 1)
' Write first color value to Target Color Array.
vntC(1, 1) = rng.Cells(1, 1).Interior.Color
' Loop through elements of Source Array.
For i = 2 To UBound(vntS)
' Check if current value is different then the previous one.
If vntS(i, 1) <> vntS(i - 1, 1) Then
' Count element of Target/Color Array.
k = k + 1
' Write from Source Array to Target Array.
vntT(k, 1) = vntS(i, 1)
' Write color values from Source Range to Color Array.
vntC(k, 1) = rng.Cells(i, 1).Interior.Color
End If
Next
' All necessary data is in Target/Color Arrays.
Erase vntS
Set rng = Nothing
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget).Cells(cTgtFR, cTgtCol)
' Clear contents of range from Target First Cell to Target Bottom Cell.
.Resize(Rows.Count - .Row + 1).ClearContents
' Calculate Target Column Range.
Set rng = .Resize(k)
' Copy Target Array to Target Range.
rng = vntT
' Apply colors to Target Range.
With rng
' Loop through cells of Target Column Range.
For i = 1 To k
' Apply color to current cell of Target Range using the values
' from Color Array.
.Cells(i, 1).Interior.Color = vntC(i, 1)
Next
End With
End With
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Create a custom function in Visual Basic Editor that will return to the color index of the cell:
Function COLOR(Target As Range)
COLOR = Target.Interior.ColorIndex
End Function
Then in the right column use a formula similar to this:
=IF(OR(A2<>A3,COLOR(A2)<>COLOR(A3)),1,0)
Then filter to show only 1's.

Find range which contains first cell only of last line?

I need to calculate a range which contains just a single cell. This cell is from the last line and first column. If the sheet is empty the range is A1:A1.
I know there are plenty of ways to calculate the last line, but I'm looking for an elegant way to get the first cell of the last line. Maybe some examples explain better.
Example #1
A B C D
1
2 X
3 X
4 X
Result #1
Range = A4:A4
Example #2
A B C D
1
Result #2
Range = A1:A1
How to do this?
If I have understood correctly, you want find the last row across some range (or bunch of columns).
One way to achieve this might be to loop over each column within the range, find what row the last cell (in that particular column), and check if it exceeds whatever the greatest last row has been thus far in the loop.
In the code below, if you change "Sheet1" to whatever your sheet is called, and change the range from "A4:Z5" to something like "A:Z" or "A1:D4" (or whatever it is in your case), it should then display the address of the cell you're after.
Option Explicit
Private Sub ShowLastCell()
' Change this to what your sheet is called.
With ThisWorkbook.Worksheets("Sheet1")
' Change this to the range you need to check.
With .Range("A4:Z5")
Dim firstColumnToCheck As Long
firstColumnToCheck = .Columns(1).Column
Dim lastColumnToCheck As Long
lastColumnToCheck = .Columns(.Columns.Count).Column
End With
Dim maxLastRow As Long
Dim columnIndex As Long
For columnIndex = firstColumnToCheck To lastColumnToCheck
maxLastRow = Application.Max(maxLastRow, .Cells(.Rows.Count, columnIndex).End(xlUp).Row)
Next columnIndex
MsgBox ("I think the cell you want is " & .Cells(maxLastRow, "A").Address & ":" & .Cells(maxLastRow, "A").Address)
End With
End Sub
GetFirstCellInLastLine will return the first cell in the last line of the referenced worksheet as a Range object. Then you can do what you want with it. For example, printing to Immediate Window for the active sheet:
Debug.Print GetFirstCellInLastLine(ActiveSheet).Address
It is setup to return Noting if the worksheet is blank, but you can modify this according to your needs:
'''
''' Returns the first used cell in the last line of the worksheet.
''' Returns "Nothing" if the worksheet is blank.
'''
Public Function GetFirstCellInLastLine(ws As Excel.Worksheet) As Excel.Range
Dim rng As Excel.Range
Set rng = ws.UsedRange.Cells(ws.UsedRange.Rows.Count, 1)
If ((ws.UsedRange.Columns.Count > 1) And ws.Range(rng, rng.End(xlToRight)).Columns.Count <= ws.UsedRange.Columns.Count) Then
Set rng = ws.Range(rng, rng.End(xlToRight))
If VBA.IsEmpty(rng.Cells(1, 1)) Then
Set rng = rng.Cells(1, rng.Columns.Count)
Else
Set rng = rng.Cells(1, 1)
End If
ElseIf (ws.UsedRange.Columns.Count = 1) And VBA.IsEmpty(rng.Cells(1, 1)) Then
Set rng = Nothing
End If
Set GetFirstCellInLastLine = rng
End Function
Last Used Row & Specified Column Intersection feat. UsedRange
One of the elegant ways would be to use the UsedRange property.
Advanced Version
'*******************************************************************************
' Purpose: Using the UsedRange Property, creates a reference to the cell *
' range at the intersection of the last used row and a specified *
' column in a worksheet and prints its address and the address *
' of the UsedRange to the Immediate Window. *
'*******************************************************************************
Sub LastUR_Column_UsedRange()
Const cVntCol As Variant = "A" ' Column
Dim objRngT As Range ' Target Range
With ThisWorkbook.Worksheets("Sheet1")
If .Cells(.UsedRange.Rows.Count + .UsedRange.Row - 1, cVntCol).Row = 1 _
And .Cells(1, Columns.Count).End(xlToLeft).Column = 1 _
And IsEmpty(.Cells(1, 1)) Then
Debug.Print "objRngT = Nothing (Empty Worksheet)"
Else
Set objRngT = .Cells(.UsedRange.Rows.Count + .UsedRange.Row - 1, cVntCol)
Debug.Print "objRngT = " & objRngT.Address & " calculated from the " _
& "used range (" & .UsedRange.Address & ")."
Set objRngT = Nothing
End If
End With
End Sub
'*******************************************************************************
Lesson Version
'*******************************************************************************
' Purpose: Using the UsedRange Property, creates a reference to the cell *
' range at the intersection of the last used row and a specified *
' column in a worksheet and prints subresults and its address *
' to the Immediate Window. *
'*******************************************************************************
Sub LastUR_Column_UsedRange_Lesson()
' When you declare the column as variant you can use
' column letter or number e.g. "A" or 1, "D" or 4 ...
Const cVntCol As Variant = "A" ' Column
Dim objRngT As Range ' Target Range
Dim lngLast As Long ' Last Row
Dim lngRows As Long ' Number of Rows
Dim lngFirst As Long ' First Row
With ThisWorkbook.Worksheets("Sheet1")
' Finding first row and number of rows is easy.
lngFirst = .UsedRange.Row
Debug.Print "lngFirst = " & lngFirst
lngRows = .UsedRange.Rows.Count
Debug.Print "lngRows = " & lngRows
' Note1: Only when there is data in the first row, the number of rows
' is equal to the last row.
' Therefore we have to calculate the last row.
lngLast = lngRows + lngFirst - 1
Debug.Print "lngLast = " & lngLast
' Now imagine you have the first data in row 2, and you have 3 rows
' which would mean the last data is in row 4 (rows 2, 3, 4). So when you add
' 2 + 3 = 5, you have to subtract 1 row, because you counted row 2 twice.
' Note2: If there is data in the first row then lngFirst = 1.
' So the formula will calculate:
' lnglast = lngRows + 1 - 1
' lngLast = lngRows + 0
' which proves the statement in Note1.
' The previous three lines could have been written in one line:
lngLast = .UsedRange.Rows.Count + .UsedRange.Row - 1
Debug.Print "lngLast = " & lngLast & " (One Row Version)"
' Now we have all the ingredients for the Target Range.
Set objRngT = .Cells(lngLast, cVntCol)
Debug.Print "objRngT = " & objRngT.Address _
& " (Before Check if Empty)"
' And again all this could have been written in one line:
Set objRngT = .Cells(.UsedRange.Rows.Count + .UsedRange.Row - 1, cVntCol)
Debug.Print "objRngT = " & objRngT.Address & " (One Row Version)" _
& " (Before Check if Empty)"
' then you wouldn't need variables lngLast, lngFirst and lngRows. On the
' other hand you wouldn't have learned how this big formula was created.
' Now the problem is that if the worksheet is empty, UsedRange will show
' the cell in the first row as the used range. So we have to address this
' issue by checking if all of the following three conditions are true.
' - Check if the resulting cell range is in the first row (1).
' - Check if from the end of the first row to the beginning the result
' is the first cell (1) (all other cells are empty).
' - Check if the cell ("A1") is empty.
If objRngT.Row = 1 And _
.Cells(1, Columns.Count).End(xlToLeft).Column = 1 And _
IsEmpty(.Cells(1, 1)) Then
Debug.Print "objRngT = Nothing (Empty Worksheet)"
Else
Debug.Print "objRngT = " & objRngT.Address
End If
' Although this is a working code, we can conclude that we should have done
' this checking at the beginning which will be done in the advanced version.
End With
Set objRngT = Nothing
End Sub
'*******************************************************************************
Last Used Row & Specified Column Intersection feat.
The Find Method
I would call this the safest and most elegant way: using the Find method.
'*******************************************************************************
' Purpose: Using the Find method, creates a reference to the cell range at *
' the intersection of the last used row and a specified column *
' in a worksheet and prints its address to the Immediate window. *
'*******************************************************************************
Sub LastUR_Column_Find()
Const cVntCol As Variant = "A" ' Column Letter or Number ("A" or 1)
Dim objRngT As Range ' Target Range
With ThisWorkbook.Worksheets("Sheet1")
If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
Is Nothing Then
Set objRngT = .Cells(.Cells.Find("*", , , , , 2).Row, cVntCol)
Debug.Print "objRngT = " & objRngT.Address
Set objRngT = Nothing
Else
Debug.Print "objRngT = Nothing (Empty Worksheet)"
End If
End With
End Sub
'*******************************************************************************
' Remarks: If you carefully study the "Find method as it applies to *
' the Range object." from "Visual Basic Help", you will realize *
' why exactly those four arguments and their parameters in *
' the If statement must be included and why three of them can *
' be omitted, but a new one has to be added in the Else clause. *
'*******************************************************************************

Trim, Copy (insert), Concatenate on selected range

I have a one dimensional column of cells containing text.
I would like to:
strip ".jpg" extension
duplicate each line and insert a copy of the duplicated line beneath it
for each duplicated line (every second line), add a suffix "-Alpha"
apply ".tif" extension to all of the cells
Data looks like this:
0120-052.jpg
0120-053.jpg
0120-054.jpg
0120-055.jpg
0120-056.jpg
I would like to select that range and it appear like so:
0120-052.tif
0120-052-Alpha.tif
0120-053.tif
0120-053-Alpha.tif
0120-054.tif
0120-054-Alpha.tif
0120-055.tif
0120-055-Alpha.tif
0120-056.tif
0120-056-Alpha.tif
I found out how to insert entire rows between the existing data, but I have other data to the left of this data and don't want to have blank rows running across my entire spreadsheet. I did find a way to insert blanks between the existing data but I could not figure out how to instead paste the data when inserting. I fudged something together, but it tried to paste infinitely.
I think I need to put it all into an array and iterate on a step by step basis, but I was unable to figure out how to do that based off of an arbitrary selection.
Sub PasteInsertRowsAfter()
Dim MyCell As Range
For Each MyCell In Selection
If MyCell.Value <> "" Then
MyCell.Copy
MyCell.Offset(1, 0).Insert shift:=xlDown
MyCell.Offset(2, 0).Select
End If
Next MyCell
End Sub
Does this work for you?
Sub PasteInsertRowsAfter()
Dim i As Long
Dim MyCell As Range
Dim Rng As Range
Set Rng = Selection
For i = Rng.Cells.Count To 1 Step -1
Set MyCell = Rng.Cells(i)
MyCell.Copy
MyCell.Offset(1, 0).Insert shift:=xlDown
MyCell.Value = Replace(MyCell.Value, ".jpg", ".tif")
MyCell.Offset(1, 0).Value = Replace(MyCell.Offset(1, 0), ".jpg", "-Alpha.tif")
Next i
End Sub
This sounds like bad data structure to me (inserting rows) so this solution will be based on a column structured table. However, I don't know much else about the data so this could be a wrong assumption on my end.
You could store your values in columns instead like so | Original String | .jpg | -Alpha.tif |
Where Original String is the header for Column A and so on. Your data will be better organized this way since all modifications of original string will be stored on a single row. This structure will allow you to add other info that may be relevant at some point in time (source, date, etc.). You can create pivots with this format and monitor for duplicates easier. You can even store the original string.
Input/Output of macro are below.
This sub is a simple loop that does not take a Slection range.
Sub Alternative()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim MyRange As Range: Set MyRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
Dim MyCell As Range
Application.ScreenUpdating = False
For Each MyCell In MyRange
MyCell.Offset(, 1) = Replace(MyCell, "jpg", "tif")
MyCell.Offset(, 2) = Replace(MyCell, ".jpg", "-Alpha.tif")
Next MyCell
Application.ScreenUpdating = True
End Sub
Here is an option that allows the user to select a range once the macro is launched. Just as the above solution, the macro will output the data in the 2 columns to left of selected range.
Sub Alternative()
Dim MyRange As Range, MyCell As Range
On Error Resume Next 'Allow for Cancel Button
Set MyRange = Application.InputBox("Select Range", Type:=8)
On Error GoTo 0
If Not MyRange Is Nothing Then
Application.ScreenUpdating = False
For Each MyCell In MyRange
MyCell.Offset(, 1) = Replace(MyCell, "jpg", "tif")
MyCell.Offset(, 2) = Replace(MyCell, ".jpg", "-Alpha.tif")
Next MyCell
Application.ScreenUpdating = True
End If
End Sub
Trim160ConcatArrayPaste
Option Explicit
'With Sub ======================================================================
' .Title: Trim160ConcatArrayPaste
' .Author: YMG
'-------------------------------------------------------------------------------
Sub Trim160ConcatArrayPaste()
'Description
' Manipulates data in a selected worksheet range and pastes the result into
' another range (overwriting the former range and more).
'Parameters
' None
'Returns
' Manipulated data in a range.
'
'-- Customize BEGIN --------------------
Const cStr1 As String = ".jpg"
Const cStr2 As String = ".tif"
Const cStr3 As String = "-Alpha.tif"
'If the result should be pasted into another row. Probably useless.
Const loROff As Long = 0 'Row Offset for Array Data
''''''''''''''''''''''''''''''''''''''''
'If the result should be pasted into another column
Const iCOff As Integer = 0 'Column Offset for Array Data
'Remarks:
' I strongly urge you to consider pasting the data into another column e.g.
' the column adjacent to the right of the starting column (Set iCoff = 1).
' If something goes wrong while pasting you will overwrite your initial data
' and you might lose a lot of time getting it back.
' Creating a log file might be considered.
''''''''''''''''''''''''''''''''''''''''
'
'-- Customize END ----------------------
'
Dim oXL As Application 'Exel Application Object
Dim oWb As Workbook 'Workbook Object - ActiveWorkbook
Dim oWs As Worksheet 'Worksheet Object - ActiveSheet
Dim oRng As Range 'Range Object - Range to read from, Range to write to
Dim oCell As Range 'Cell - Range Object - All cells of oRng
Dim arrTCC() As String
Dim lo1 As Long 'Data Entries Counter, Array Entries Counter
Dim strCell As String
Dim strArrRng As String
'
'-------------------------------------------------------------------------------
'Assumptions
' There is a contiguous range (oRng) in the ActiveSheet (oWs) of the
' ActiveWorkbook (oWb) that contains a list of entries in its cells
' (oRng.Cells) to be processed. ('Data' for 'list of entries' in further text)
' The actual range of the Data is selected.
'-------------------------------------------------------------------------------
'
Set oXL = Application
Set oWb = ActiveWorkbook
Set oWs = oWb.ActiveSheet
Set oRng = oXL.Selection
'
'Remarks:
' The Selection Property is a property of the Application object and the
' Window object. Visual Basic doesn't allow ActiveWorkbook.Selection or
' ActiveSheet.Selection.
'
''''''''''''''''''''''''''''''''''''''''
'Task:
' Count the number of Data entries.
'
lo1 = 0 'Data Entries Counter
For Each oCell In oRng.Cells
lo1 = lo1 + 1
Next
'
'Status:
' 'lo1' is the number of Data entries which will be used to determine the
' size of an array in the following code.
'
''''''''''''''''''''''''''''''''''''''''
'Task: Populate an array with the desired results.
'
ReDim arrTCC(1 To lo1 * 2, 1 To 1)
'Explaination:
'"lo1" - Number of list entries.
'" * 2" - Making 2 entries out of each entry.
lo1 = 0 'Array Entries Counter (This is a 1-based array.)
For Each oCell In oRng.Cells
'Clean the text of the Data entries.
strCell = Trim(oCell.Text)
'Remarks:
'Chr(160) which is a non-breaking space (HTML Name: ) is at
'the end of the Data entries. The Trim function doen't clean
'non-breaking spaces.
strCell = Replace(strCell, Chr(160), "")
'Check the last part of the string
If Right(strCell, Len(cStr1)) = cStr1 Then
'Populate array.
lo1 = lo1 + 1
arrTCC(lo1, 1) = Replace(strCell, cStr1, cStr2)
lo1 = lo1 + 1
arrTCC(lo1, 1) = Replace(strCell, cStr1, cStr3)
'If the cell doesn't end with cStr1:
Else 'This should never happen, remember: COUNTIGUOUS.
'An Idea
' lo1 = lo1 + 1
' arrTCC(lo1, 1) = ""
' lo1 = lo1 + 1
' arrTCC(lo1, 1) = ""
MsgBox "You might have selected a wrong range.", vbCritical
Exit Sub
End If
Next
'
' For lo1 = LBound(arrTCC) To UBound(arrTCC)
' Debug.Print arrTCC(lo1, 1)
' Next
' Debug.Print LBound(arrTCC)
' Debug.Print UBound(arrTCC)
'
'Status: The array 'arrTCC' is populated
'
''''''''''''''''''''''''''''''''''''''''
'Task:
' Determine the range where to paste the data from array and paste the
' array into the range.
'
'Calculate the 'Start' Cell Address
strArrRng = oRng.Cells(1 + loROff, 1 + iCOff).Address
'
' Debug.Print strArrRng
'
'Add the ":" (Address Separator) and the Calculated 'End' Cell Address
strArrRng = strArrRng & ":" & _
oRng.Cells(UBound(arrTCC) + loROff, 1 + iCOff).Address
'Paste the Array to the Worksheet
Set oRng = oWs.Range(strArrRng)
'
' Debug.Print strArrRng
' Debug.Print oRng.Address
'
oRng = arrTCC
'
'Status: Done
'
'Remarks:
'Testing the program was done with iCoff = 1 i.e. pasting the array data
'into the column adjacent to the right of the starting column. Since it uses
'overwriting the Data, the Data would always need to be written back for
'further testing.
'Some debugging code has deliberately been commented and left inside the
'program to remind amateurs like myself of debugging importance.
'Some other aspects of this program could be considered like the column
'of the data could be known or unknown so a range, a column or the
'ActiveCell would have or don't have to be selected etc.
'
End Sub
'-------------------------------------------------------------------------------
'With Source Idea --------------------------------------------------------------
' .Title: Excel VBA seemingly simple problem: Trim, Copy (insert), Concat on selected range
' .TitleLink: https://stackoverflow.com/questions/52548294/excel-vba-seemingly-simple-problem-trim-copy-insert-concat-on-selected-rang
' .Author: NewbieStackOr
' .AuthorLink: https://stackoverflow.com/users/10427336/newbiestackor
'End With ----------------------------------------------------------------------
'End With ======================================================================

Resources