I have 4 columns, A through D. I need to find rows where column C is the same in each row, and column D is the same in each row. It would be best to have a True or False value placed in column E. VBA or a formula works, although I'd think something like this is do-able with a formula.
For example, I have the following:
Row 1 XX 123 XYZ
Row 2 XX 234 XYZ
Row 3 XX 234 YZX
Row 4 XX 234 YZX
In this example, Column E would be False for Rows 1 and 2 and True for Rows 3 and 4.
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = Sheets("Sheet1")
With ws
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If i = 1 Then
If .Range("C" & i).Value = .Range("C" & i + 1).Value And _
.Range("D" & i).Value = .Range("D" & i + 1).Value Then _
.Range("E" & i).Value = "True" Else .Range("E" & i).Value = "False"
Else
If (.Range("C" & i).Value = .Range("C" & i + 1).Value And _
.Range("D" & i).Value = .Range("D" & i + 1).Value) Or _
(.Range("C" & i).Value = .Range("C" & i - 1).Value And _
.Range("D" & i).Value = .Range("D" & i - 1).Value) Then _
.Range("E" & i).Value = "True" Else .Range("E" & i).Value = "False"
End If
Next i
End With
End Sub
SNAPSHOT
Related
The AE, AG, AH, whenever the D or AD parallel cells are empty, return e.g. date of 00/01/1900 or time as 00:00. Can you please clarify how to return blank if the same parallel cell in D or AD is blank? Thanks
Sub valuedifference()
Dim Total As Double
Dim TimeX As Date
Dim TimeY As Date
Dim LastRow As Long
Dim i As Long
With ThisWorkbook.Sheets("Test1")
LastRow = .Cells(.Rows.Count, "d").End(xlUp).Row
For i = 2 To LastRow
TimeX = CDate(.Range("d" & i).Value)
TimeY = CDate(.Range("ad" & i).Value)
Total = TimeValue(TimeY) - TimeValue(TimeX)
.Range("ae" & i).Value = Total
.Range("ag" & i).Value = Abs(Total * 24)
.Range("ah" & i).Value = Abs(Total * 1440)
Next i
End With
End Sub
I think this a formatting issue- If TimeY is "" and TimeX is "", then
Total = TimeValue(TimeY) - TimeValue(TimeX) is 0.
0 in time format is 0:0:00 and 0 in date format is 00/01/1900
One solution to this is to include an if statement that checks that there are not blank cells
For i = 2 To LastRow
If .Range("D" & i).Value <> "" And .Range("AD" & i).Value <> "" Then
TimeX = CDate(.Range("d" & i).Value)
TimeY = CDate(.Range("ad" & i).Value)
Total = DateDiff("n", TimeY, TimeX)
.Range("AE" & i).Value = Total
.Range("AG" & i).Value = Format(Abs(Total), "#.##")
.Range("AH" & i).Value = Format(Abs(Total), "#.##")
End If
Next i
I am trying to copy from Raw Data to Consolidated Data.
If a row in the Raw Data already exists (by checking both the Full Name and the Identity Number together with the AND Condition as the composite key of using both values is unique) in the Consolidated Data it will check through the columns and update it if there are any changes.
For example Ben with the Identity Number of 3333 changed his Contact and Email. So after updating it will have the updated Contact and Email.
Secondly, if the row in the Raw Data doesn't exist it will add to the bottom of the Consolidated Data.
I tried a nested loop for this. I am facing the problem of duplicate entries as my code is checking the row in the Raw Data with every row in the Consolidated Data.
For example in the Raw Data I have Alan (1111), Ben (2222), Ben (3333), Calvin (4444). In the New Consolidated Data I will turn out to have more than four rows after updating.
This is the raw data
This is the old consolidated data
This is the final consolidated data
Dim i As Long, lastRow As Long
Set rawData = sheet1
Set finalData = sheet2
lastRow = sheet1.Cells(rows.Count, "A").End(xlUp).Row
finalLastRow = sheet2.Cells(rows.Count, "A").End(xlUp).Row
MsgBox lastRow
MsgBox finalLastRow
' If the sheet is empty
If (finalLastRow = 2) Then
For i = 3 To lastRow
' Test if cell if empty
If (rawData.range("A" & i).Value <> "") Then
finalData.range("A" & i).Value = rawData.range("A" & i).Value
finalData.rNeange("B" & i).Value = rawData.range("B" & i).Value
finalData.range("C" & i).Value = rawData.range("C" & i).Value
finalData.range("D" & i).Value = rawData.range("D" & i).Value
finalData.range("E" & i).Value = rawData.range("E" & i).Value
End If
Next i
' If the sheet is not empty
ElseIf (finalLastRow <> 2) Then
Dim newLastRow As Long
newLastRow = 4
For i = 3 To lastRow
For j = 3 To finalLastRow
' Test if cell is the same
'Dim matchScore As Long
' Full Name and Identity Number remain same
If (rawData.range("A" & i).Value) = (finalData.range("A" & j).Value) And (rawData.range("B" & i).Value) = (finalData.range("B" & j).Value) Then
finalData.range("C" & j).Value = rawData.range("C" & i).Value
finalData.range("D" & j).Value = rawData.range("D" & i).Value
finalData.range("E" & j).Value = rawData.range("E" & i).Value
MsgBox "SAME"
' New Record
Else
' Check through the sheet2 to see if the row have been added to it
newLastRow = newLastRow + 1
finalData.range("B" & newLastRow).Value = rawData.range("B" & i).Value
End If
finalLastRow = sheet2.Cells(rows.Count, "A").End(xlUp).Row
Next j
Next i
End If
I have added another For loop in the Else statement to check through the columns to see if it exists.
' New Record
Else
Dim isDataInCurrentRows As Boolean
isDataInCurrentRows = False
For checkRow = 3 To finalLastRow
If (rawData.range("B" & i).Value) = (finalData.range("B" & checkRow).Value) And (rawData.range("D" & i).Value) = (finalData.range("D" & checkRow).Value) Then
isDataInCurrentRows = True
Exit For
End If
Next checkRow
If isDataInCurrentRows = False Then
finalData.range("A" & finalLastRow + 1).Value = rawData.range("A" & i).Value
finalData.range("B" & finalLastRow + 1).Value = rawData.range("B" & i).Value
finalData.range("C" & finalLastRow + 1).Value = rawData.range("C" & i).Value
finalData.range("D" & finalLastRow + 1).Value = rawData.range("D" & i).Value
finalData.range("E" & finalLastRow + 1).Value = rawData.range("E" & i).Value
finalData.range("F" & finalLastRow + 1).Value = rawData.range("F" & i).Value
finalData.range("G" & finalLastRow + 1).Value = rawData.range("G" & i).Value
finalData.range("H" & finalLastRow + 1).Value = rawData.range("H" & i).Value
finalData.range("I" & finalLastRow + 1).Value = Date
End If
End If
I need to read all the data cell which have the entries but I only need to highlight the cells which have a character more than 10 in that data cell.
For example:
In the A column I need to read all the data but my condition is that I need to highlight the cell which contains more than 10 char.
Likewise In the B column I need to do the same thing but here I need to highlight the cell which contains more than 12 char.
Likewise I want to implement one solution for all the columns which contains the data.
Please help me to resolve it.
The code I tried:
Sub Dendrinos2()
Dim i As Long
Dim lr As Long
lr = Cells(Rows.Count, 5).End(xlUp).Row
For i = lr To 2 Step -1
If Range("C" & i).Value > 6 Then Range("C" & i).Interior.ColorIndex = 3
If Range("G" & i).Value > 3 Then Range("G" & i).Interior.ColorIndex = 3
If Range("I" & i).Value > 3 Then Range("I" & i).Interior.ColorIndex = 3
If Range("C" & i).Value < -3 Then Range("C" & i).Interior.ColorIndex = 3
If Range("G" & i).Value < -3 Then Range("G" & i).Interior.ColorIndex = 3
If Range("I" & i).Value < -3 Then Range("I" & i).Interior.ColorIndex = 3
If Range("E" & i).Value = "--" Then Range("E" & i).Interior.ColorIndex = Range("A" & i).Interior.ColorIndex
If Range("G" & i).Value = "--" Then Range("G" & i).Interior.ColorIndex = Range("A" & i).Interior.ColorIndex
If Range("I" & i).Value = "--" Then Range("I" & i).Interior.ColorIndex = Range("A" & i).Interior.ColorIndex
Next i
End Sub
Use conditional formatting with a simple formula that covers columns A and B.
Sub highlightLength()
With Worksheets("sheet3")
With .Range("A:B")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=len(a1)>(column(a1)+4)*2"
With .FormatConditions(.FormatConditions.Count)
.Interior.Color = vbYellow
End With
End With
End With
End Sub
I would do something like this:
Sub Dendrinos2()
Dim i As Long
Dim lr As Long
Dim sht As Worksheet
Set sht = ActiveSheet
lr = sht.Cells(sht.Rows.Count, 5).End(xlUp).Row
For i = lr To 2 Step -1
Checklength sht.Range("A" & i), 10
Checklength sht.Range("B" & i), 12
CheckLimits sht.Range("C" & i), -3, 6
CheckLimits sht.Range("G" & i), -3, 3
CheckLimits sht.Range("I" & i), -3, 3
CheckDashes sht.Range("E" & i), sht.Range("A" & i)
CheckDashes sht.Range("G" & i), sht.Range("A" & i)
CheckDashes sht.Range("I" & i), sht.Range("A" & i)
Next i
End Sub
Sub CheckLimits(c As Range, ll, ul)
With c
If .Value < ll Or .Value > ul Then .Interior.ColorIndex = 3
End With
End Sub
Sub CheckDashes(c As Range, cA As Range)
With c
If .Value = "--" Then
.Interior.ColorIndex = cA.Interior.ColorIndex
End If
End With
End Sub
Sub Checklength(c As Range, l As Long)
With c
If Len(.Value) > l Then .Interior.ColorIndex = 3
End With
End Sub
Final One:enter image description hereI want to insert blank row with a specific column range above a particular row.
For example:
There were 2 sets of data in a single sheet ,ie, 1st set col A to Col E and 2nd set Col F to Col J. I need to compare Column Ai with Column Fi (where i indicates the position of row) and if both values are same then the comparison can be proceeded like Bi with Gi, Ci with Hi and so and so and if not, I need to shift that set of 2nd data Fi to Ji to next row..ie. if the whole set is in 6th position I need to shift them down to 7th position and make the 6th position of Fi to Ji blank....
Sub Dcompare()
Dim endRow As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
endRow = Sheet1.Range("A999999").End(xlUp).Row
For i = 2 To endRow
If Sheet1.Range("A" & i).Value = Sheet1.Range("F" & i).Value Then
Sheet1.Range("K" & i).Value = "Yes"
Else
ws.Range("F" & i & ":J" & i).Offset(1, 0).Value = ws.Range("F" & i & ":J" & i).Value
ws.Range("F" & i & ":J" & i).Value = ""
End If
Next i
For j = 2 To endRow
If Sheet1.Range("K" & j).Value = "Yes" Then
If Sheet1.Range("B" & j).Value = Sheet1.Range("G" & j).Value Then
Sheet1.Range("L" & j).Value = "Yes"
Else
Sheet1.Range("L" & j).Value = "No"
End If
If Sheet1.Range("C" & j).Value = Sheet1.Range("H" & j).Value Then
Sheet1.Range("M" & j).Value = "Yes"
Else
Sheet1.Range("M" & j).Value = "No"
End If
If Sheet1.Range("D" & j).Value = Sheet1.Range("I" & j).Value Then
Sheet1.Range("N" & j).Value = "Yes"
Else
Sheet1.Range("N" & j).Value = "No"
End If
If Sheet1.Range("E" & j).Value = Sheet1.Range("J" & j).Value Then
Sheet1.Range("O" & j).Value = "Yes"
Else
Sheet1.Range("O" & j).Value = "No"
End If
End If
Next j
End Sub
------>Final Code Inserted---------
Sub Dcompare()
Dim endRow As Long
Dim ws As Worksheet
Dim dShift As Boolean
Set ws = ThisWorkbook.Worksheets(1)
endRow = ws.Range("A999999").End(xlUp).Row
For i = 2 To endRow + 1
If ws.Range("A" & i).Value = ws.Range("F" & i).Value Then
dShift = False
ws.Range("K" & i).Value = "Yes"
Else
If Not dShift Then
ws.Range("F" & i & ":J" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ws.Range("A" & i + 1 & ":E" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
endRow = endRow + 1
dShift = True
Else
dShift = False
End If
End If
j = i
If ws.Range("K" & j).Value = "Yes" Then
If ws.Range("B" & j).Value = ws.Range("G" & j).Value Then
ws.Range("L" & j).Value = "Yes"
Else
ws.Range("L" & j).Value = "No"
End If
If ws.Range("C" & j).Value = ws.Range("H" & j).Value Then
ws.Range("M" & j).Value = "Yes"
Else
ws.Range("M" & j).Value = "No"
End If
If ws.Range("D" & j).Value = ws.Range("I" & j).Value Then
ws.Range("N" & j).Value = "Yes"
Else
ws.Range("N" & j).Value = "No"
End If
If ws.Range("E" & j).Value = ws.Range("J" & j).Value Then
ws.Range("O" & j).Value = "Yes"
Else
ws.Range("O" & j).Value = "No"
End If
Else
End If
Next i
MsgBox "The value of endRow is : " & endRow, vbInformation
End Sub
Based on your explanations, this is what I interpret your challenge as:
Evaluate Ai with Fi --> Ei with Ji from left to right, and indicate in helper-columns whether the evaluation succeeded or not
If the first evaluation is Not Equal, offset the range Fi:Ji downwards exactly one row
If a range has been shifted down, the loop should evaluate this line but never shift it again regardless of outcome of the evaluation
This code satisfies those conditions (change i and other row variables to your needs):
Sub Dcompare()
Dim endRow As Long
Dim ws As Worksheet
Dim dShift As Boolean
Set ws = ThisWorkbook.Worksheets(1)
endRow = ws.Range("A999999").End(xlUp).Row
' Set initial value of helper columns to no - saves miniscule time and complexity in the loop
ws.Range("L" & 1 & ":O" & endRow).Value = "No"
For i = 1 To endRow
If ws.Range("A" & i).Value = ws.Range("F" & i).Value Then
dShift = False
ws.Range("L" & i).Value = "Yes"
Else
If Not dShift Then
ws.Range("F" & i & ":J" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' Remember that we just shifted a row
dShift = True
Else
' Reset shift counter
dShift = False
End If
End If
For j = 2 To 4
If dShift Then Exit For
If ws.Cells(i, j).Value = ws.Cells(i, j + 5).Value Then ws.Cells(i, j + 11).Value = "Yes"
Next j
Next i
End Sub
However, it seems strange to me that you would want this functionality? Please confirm that it is correct. The behavior it yields in the worksheet is very strange.
Let me show with images. Orange background means the code will show the cell as a match. Green background means the code will show that the cell doesn't match.
Before the code it looks like this:
After the code it looks like this:
I want to copy cell data from "Sheet2" to "Sheet1" if the value in column "H" on "Sheet2" is not equal to "0" (zero).
If the statement is true, I want to copy
"Sheet2:A2" to "Sheet1:A7",
"Sheet2:F2" to "Sheet1:C7",
"Sheet2:G2" to "Sheet1:E7", and
"Sheet2:H2" to "Sheet1:G7".
I then want to loop through the remaining rows on "Sheet2" and continue copying until the worksheet runs out of data.
Use the following code
Sub filldata()
LastRow = Sheet2.Range("H1048576").End(xlUp).Row
i = 2
j = 7
For i = 2 To LastRow
If Sheet2.Range("H" & i).Value <> 0 Then 'the condition to check
Sheet1.Range("A" & j).Value = Sheet2.Range("A" & i).Value
Sheet1.Range("C" & j).Value = Sheet2.Range("F" & i).Value
Sheet1.Range("E" & j).Value = Sheet2.Range("G" & i).Value
Sheet1.Range("G" & j).Value = Sheet2.Range("H" & i).Value
j = j + 1
End If
Next
End Sub