i'm working on a Excel VBA Macro that can match the same entries in column V with the entries in column Y. Everything works fine but there some entries that just match a part of the other entry.
Example:
Column V: Column Y:
Word Excel
Word, Excel
Excel
Now for this example it will only mark the last entry, but it should also mark the secound entry.
Here's the code that i actually have now:
Sub MatchAndColor()
Dim lastRow As Long
Dim sheetName As String
sheetName = "MAIN" 'Name of the Sheet
lastRow = Sheets(sheetName).Range("V" & Rows.Count).End(xlUp).Row
lastRowB = Sheets(sheetName).Range("Y" & Rows.Count).End(xlUp).Row
For lrow = 2 To lastRow 'Loop through all rows
For lrowb = 2 To lastRowB 'Loop through all rows
If Sheets(sheetName).Cells(lrow, "V") Like Sheets(sheetName).Cells(lrowb, "Y") Then
Sheets(sheetName).Cells(lrow, "V").Interior.ColorIndex = 37 'Set Color to Light Blue
End If
Next lrowb
Next lrow
End Sub
Thank you for your help!
EDIT
Updated answer to match question update, this works with given example.
Sub MatchAndColor()
Dim lastRow As Long
Dim sheetName As String
sheetName = "MAIN" 'Name of the Sheet
lastRow = Sheets(sheetName).Range("V" & Rows.Count).End(xlUp).Row
lastRowB = Sheets(sheetName).Range("Y" & Rows.Count).End(xlUp).Row
For lrow = 2 To lastRow 'Loop through all rows
For lrowb = 2 To lastRowB 'Loop through all rows
If (Sheets(sheetName).Cells(lrow, "V") Like "*" & Sheets(sheetName).Cells(lrowb, "Y") & "*") Or (Sheets(sheetName).Cells(lrow, "Y") Like "*" & Sheets(sheetName).Cells(lrowb, "V") & "*") Then
Sheets(sheetName).Cells(lrow, "V").Interior.ColorIndex = 37 'Set Color to Light Blue
End If
Next lrowb
Next lrow
End Sub
Related
I want to get a sum based on the criteria of the preceding column data. Suppose I have three columns say A, B and C. So, "A" columns have the Sr.no. let's say, "B" has the quantity and "C" have the total quantity. I am trying to sum the quantity in column "B" based on the Sr.no. in column "A" and paste it to column "C" (after merging that many cells) against the respective Sr.no. (Which we have in column "A"). Refer image attached Image.
Sub sum_on_condition()
Dim sum_criteria As Double
Dim lastrow As Long, x As Long
Dim l_array As Variant
Dim l_number As Long
lastrow = range("A" & Rows.Count).End(xlUp).Row
l_array = range("I2:I21").Value
counter = 1
While counter <= UBound(l_array)
l_number = l_array(counter, 1)
For x = 2 To lastrow
If range("e" & x).Value = l_number Then
sum_criteria = sum_criteria + range("f" & x).Value
End If
Next x
counter = counter + 1
Wend
Debug.Print sum_criteria
End Sub
I have written this code but what it does it sums the total value rather than the individual value. I am not able to figure out how I do this!
Here's another approach:
Sub SumAndMerge()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim firstItem As Long, lastItem As Long
Dim i As Long, j As Long
Dim c As Range, d As Range
Dim valueToFind As String
Dim total As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
'Get valueToFind
valueToFind = ws.Cells(i, 1).value
'Get range of cells with .Find : look up for first value and last value and get row number.
With ws.Range("A" & i & ":" & "A" & lastRow)
Set c = .Find(valueToFind, LookAt:=xlWhole)
firstItem = c.Row - 1
Set d = .Find(valueToFind, LookAt:=xlWhole, SearchDirection:=xlPrevious)
lastItem = d.Row
End With
'Get total
total = WorksheetFunction.Sum(ws.Range("B" & firstItem & ":" & "B" & lastItem))
'Assign total to first cell
ws.Range("C" & firstItem).value = total
'Merge cells
ws.Range("C" & firstItem & ":" & "C" & lastItem).Merge
'Go to lastItem to adapt the loop
i = lastItem
Next i
End Sub
Gives the following output:
Rather than using an array, this macro aims at using the Find function. In a loop, we find the first value and the last value. We extract row numbers and then we can assign the total and finally merge cells.
This code can be improved by replacing harcoded A, B and C. But this gives you an example.
I need column J to be filled with the value 1 in all cells until the rows that are filled in column A. Could someone provide me with the vba code for the same? Thanks in advance.
If you want to autofill 2010 until the row of column B with value 1:
Sub test()
Dim lastrow As Long
lastrow = Range("B" & Rows.Count).End(xlUp).Row
Range("A2:A" & lastrow).Value = 2010
End Sub
Give a try on below codes-
Sub FillCells()
Dim lr As Long, i As Long
Dim rng As Range
lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lr
Cells(i, "J") = 1
Next i
End Sub
Please, try the next code line:
Range("J2:J" & Range("A" & rows.count).End(xlUp).row).Value = 1
Edited
You asked in a comment to another answer something about doing it for specific sheets.
Please, try the next way:
Dim ws As Worksheet, i As Long
For i = 2 To 5
Set ws = ActiveWorkbook.Worksheets(i)
ws.Range("J2:J" & ws.Range("A" & ws.rows.count).End(xlUp).row).Value = 1
Next i
Please help a newbie.
Using Excel VBA, I am trying to format the text in column A with hyphens but only if column B contains the letter B.
I have found the code below, one which formats the cells in column A with hyphens, and another code which checks column B for the correct value, but cannot seem to combine them to work. Help please.
Thank you.
Sub AddDashes()
Dim Cell As Range
On Error GoTo NoFilledCells
For Each Cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeConstants)
Cell.Value = Format(Replace(Cell.Value, "-", ""), "#####-###-####")
Next
NoFilledCells:
End Sub
and
Sub ChangeColumn()
Dim LastRow As Long
Dim i As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Range("B" & i).Value = "B" Then
Range("A" & i).Value = "Formatted text with hyphens as above"
End If
Next i
End Sub
Option Explicit
Sub AddDashes()
Dim ws As Worksheet, cell As Range
Dim LastRow As Long
Set ws = ActiveSheet
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In ws.Range("A2:A" & LastRow)
If cell.Offset(0, 1) = "B" Then ' col B
cell.Value = Format(Replace(cell.Value, "-", ""), "#####-###-####")
End If
Next
End Sub
I want that if cell in column e is not blank but cell in column i is blank then write unregister in column i or else write what ever written in column i.
Please help - I have used below code:
Sub Simple_If()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "F").End(xlUp).Row
If Range("e2:e" & lastrow).Value <> "" And Range("i2:i" & lastrow).Value = "" Then
Range("i2:i" & lastrow).Value = "unregister"
End If
End Sub
The reason your code was not working is because you can't get .value of a .range (Range("e2:e" & lastrow).Value <> ""). Instead, use a for loop to iterate through each cells value individually.
I have commented each line of the code below to help you understand what is happening.
To make this work, change SO.xlsm to the name of your workbook and 63649177 to the name of your worksheet.
Sub Simple_If()
Dim WB As Workbook ' workbook - full name of the file containing data.
Dim WS As Worksheet ' worksheet - worksheet within workbook containing data.
Dim lRow As Long ' last row - find last row containing data
Dim i As Long ' iteration - used for loop
Set WB = Workbooks("SO.xlsm") ' set the name of the workbook here
Set WS = WB.Worksheets("63649177") ' set the name of the worksheet here
lRow = WS.Cells(WS.Rows.count, "E").End(xlUp).Row ' find the last row of E in the WS object, not user defined.
Set Rng = WS.Range("E2:E" & lRow) ' set the initial range
For i = 2 To lRow ' from line 2 to the last row, repeat this loop
If WS.Range("E" & i).Value <> "" And WS.Range("I" & i).Value = "" Then ' if E contains data and I does not then
WS.Range("I" & i).Value = "unregister" ' fill cell with "unregister"
End If ' end if
Next ' cycle through next iteration of loop
End Sub
Output
Loop Through Rows
You were trying to check the values of two ranges "E2:E & LastRow" and "I2:I & LastRow" in one go, but you cannot do that. You have to loop through the rows of the ranges and check each cell i.e. "E2", "E3", "E4" ... "E" & LastRow and "I2", "I3", "I4" ... "I" & LastRow. For this task a For Next loop can used.
The 1st code is showing how it is done using Range.
The 2nd code is showing how it is done using column strings (letters) with Cells.
The 3rd code is showing how it is done using column numbers with Cells.
The 4th code is showing how you can define the column ranges (rng1, rng2) and use Cells with one parameter.
The 5th code is showing how you can define constants to store the so called 'magic' characters and later quickly access (change) them. It is also modified to be able to change the resulting column (tgtCol).
Range might seem easier, but you have to learn Cells, too, e.g. because you cannot loop through columns using Range, you have to use column numbers with Cells.
Study the first three codes closely, and you will learn the differences soon enough.
The Code
Option Explicit
Sub fillSimpleRangeVersion()
' Calculate the last non-blank cell in column "F".
Dim LastRow As Long
LastRow = Range("F" & Rows.Count).End(xlUp).Row
Dim i As Long
' Loop through the rows from 2 to LastRow.
For i = 2 To LastRow ' i will change: "2, 3, 4 ... LastRow"
' Check that current cell in column "E" is not blank and
' that current cell in column "I" is blank:
' If not E2 blank and I2 blank then,
' If not E3 blank and I3 blank then ...
' If not E & LastRow blank and I & LastRow blank then.
If Not IsEmpty(Range("E" & i)) And IsEmpty(Range("I" & i)) Then
' If true, write "unregister" to current cell in column "I".
Range("I" & i).Value = "unregister"
' The Else statement is not needed, because you only write when
' the condition is true.
Else
' If not true, do nothing.
End If
Next i
End Sub
Sub fillSimpleCellsStringsVersion() ' Column Strings E, F, I
Dim LastRow As Long
LastRow = Cells(Rows.Count, "F").End(xlUp).Row
Dim i As Long
For i = 2 To LastRow
If Not IsEmpty(Cells(i, "E")) And IsEmpty(Cells(i, "I")) Then
Cells(i, "I").Value = "unregister"
End If
Next i
End Sub
Sub fillSimpleCellsNumbersVersion() ' Column Numbers 5, 6, 9
Dim LastRow As Long
LastRow = Cells(Rows.Count, 6).End(xlUp).Row
Dim i As Long
For i = 2 To LastRow
If Not IsEmpty(Cells(i, 5)) And IsEmpty(Cells(i, 9)) Then
Cells(i, 9).Value = "unregister"
End If
Next i
End Sub
Sub fillSimpleCellsVersionWithRanges()
Dim LastRow As Long
LastRow = Cells(Rows.Count, "F").End(xlUp).Row
Dim rng1 As Range
Set rng1 = Range("E2:E" & LastRow)
Dim rng2 As Range
Set rng2 = Range("I2:I" & LastRow)
Dim i As Long
For i = 1 To rng1.Rows.Count
If rng1.Cells(i).Value <> "" And rng2.Cells(i).Value = "" Then
rng2.Cells(i).Value = "unregister"
End If
Next i
End Sub
Sub fillSimpleCellsExpanded()
Const FirstRow As Long = 2 ' First Row
Const LastRowCol As Variant = "F" ' The column to Calculate Last Row
Const Col1 As Variant = "E" ' Column 1
Const Col2 As Variant = "I" ' Column 2
Const tgtCol As Variant = "I" ' Target Column, the Column to Write to
' You want to write to the same column "CritCol2 = tgtCol", but if you
' want to write to another column, you can easily change "tgtCol".
Const Criteria As String = "unregister" ' Write Criteria
Dim LastRow As Long
LastRow = Cells(Rows.Count, LastRowCol).End(xlUp).Row
Dim i As Long
For i = FirstRow To LastRow
If Not IsEmpty(Cells(i, Col1)) And IsEmpty(Cells(i, Col2)) Then
Cells(i, tgtCol).Value = Criteria
Else
' The following line is only needed if "CritCol2" is different
' than "tgtCol".
Cells(i, tgtCol).Value = Cells(i, Col2).Value
End If
Next i
End Sub
I need a macro to write the row values present in column A if there is a value present in column B .
For example :
Column A Column B
Arjun
Arun 12
For the above example, I need a macro which can write "Arun 12" in Sheet2 of the work book with the Headers "Name" and "Hours".Before this the macro should clear the data present in Sheet two completely.
This will copy the all rows of columns A and B from Sheet1 to Sheet2 if B is not a Null string. And also will add the headers "Name" and "Hours".
Option Explicit 'requires that every variable has to be defined before use, e.g. with a Dim statement.
Sub DoStuff_GoodPractice()
Dim lastRowSrc As Long, lastRowDest As Long, i As Long 'declare row counts as Long so all rows can be used
Dim shtSource As Worksheet, shtDestination As Worksheet
Set shtSource = ThisWorkbook.Worksheets("Sheet1") 'full qualified identification of the worksheets
Set shtDestination = ThisWorkbook.Sheets("Sheet2")
lastRowSrc = shtSource.Range("A" & shtSource.Rows.Count).End(xlUp).Row 'determine the last used row
'clear destination sheet and write headers:
shtDestination.Cells.Clear
shtDestination.Range("A1").Value = "Name"
shtDestination.Range("B1").Value = "Hours"
lastRowDest = 1 'start with row 1 as destination
For i = 1 To lastRowSrc 'loop through all used rows
If shtSource.Range("A" & i).Value <> vbNullString And _
shtSource.Range("B" & i).Value <> vbNullString Then 'check if cells are not a null string
shtSource.Range("A" & i & ":B" & i).Copy Destination:=shtDestination.Range("A" & lastRowDest + 1) 'copy current row
lastRowDest = lastRowDest + 1 'jump to the last used row in destination
End If
Next i
End Sub
This should accomplish what you're after.
Sub DoStuff()
Dim lastRow As integer, lastRowSheet2 As integer, i As Integer
Dim sheet1 As WorkSheet, sheet2 As Worksheet
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")
lastRow = sheet1.Range("A" & Rows.Count).End(xlUp).Row
sheet2.Cells.Clear
For i = 1 To lastRow
If sheet1.Range("A" & i).Value <> "" And sheet1.Range("B" & i).Value <> "" then
lastRowSheet2 = sheet2.Range("A" & Rows.Count).End(xlUp).Row
sheet1.Range("A" & i & ":B" & i).Copy Destination:= sheet2.Range("A" & lastRowSheet2 + 1)
End If
Next i
End Sub