Oct 30 2022 09:04 AM
Hi Guys I am not an expert on Excel and searching for a solution. I have a sheet with lots of data and some of have to change in order.
The macro I am looking for is like this...
If multiple rows have the same value in "column C"
And If multiple rows have the same value in "column C"
Hopefully someone can help me. Thanks a lot :)
Oct 30 2022 02:42 PM
SolutionSome of your request is ambiguous.
So I believe you want:
...to become:
If I'm correct, consider this procedure (feel free to change the name). I expect it will work even if column C does not contain text.
Sub Martin()
Dim objWorksheet As Worksheet
Dim in4FirstDataRow As Long
Dim in4InitialLastRow As Long
Dim in4Row As Long
Dim strRow As String
Dim in4NewLastRow As Long
Dim strNewLastRow As String
'
Dim strColCValue As String
Dim strFormula As String
Dim in4MatchRelRow As Long
Dim in4RowToPossiblyCopy As Long
Dim in4RowToCopy As Long
Dim strRowToCopy As String
'----
Set objWorksheet = ActiveSheet '<<< If you want changes on the active worksheet, or...
Set objWorksheet = Sheets("Martin2") '<<< if you want changes on a specific worksheet
With objWorksheet
in4FirstDataRow = 2 '<<< You may need to change this value, or _
include code to calculate it.
in4InitialLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
in4NewLastRow = in4InitialLastRow
'
For in4Row = in4FirstDataRow To in4InitialLastRow - 1
strColCValue = .Range("C" & CStr(in4Row)).Value
strFormula = "MATCH(""" _
& Replace(strColCValue, """", """""") _
& """, C" & CStr(in4Row + 1) _
& ":C" & CStr(in4InitialLastRow) _
& ",0)"
in4MatchRelRow = 0
On Error Resume Next
in4MatchRelRow = .Evaluate(strFormula)
On Error GoTo 0
If in4MatchRelRow = 0 Then
'...this row has no "duplicate" in column C
' among the original rows below it.
GoTo NextRowToExamine
End If
' -- We've found at least one "duplicate".
' Locate the last among these "duplicates".
For in4RowToPossiblyCopy = in4InitialLastRow To _
(in4Row + in4MatchRelRow) Step -1
If StrComp(.Range("C" & in4RowToPossiblyCopy).Value _
, strColCValue, vbTextCompare) = 0 Then
'...a match; this is the one to copy.
in4RowToCopy = in4RowToPossiblyCopy
Exit For
End If
Next in4RowToPossiblyCopy
' -- Copy that row to the end of the data.
in4NewLastRow = in4NewLastRow + 1
strNewLastRow = CStr(in4NewLastRow)
strRowToCopy = CStr(in4RowToCopy)
.Range("A" & strRowToCopy).EntireRow.Copy _
(.Range("A" & strNewLastRow))
' -- Clear/change columns in the new row.
.Range("D" & strNewLastRow & ":G" & strNewLastRow) _
.ClearContents
.Range("H" & strNewLastRow).Value = _
.Range("C" & strRowToCopy).Value
' -- As this current row is NOT the last row that has
' the same column C value, clear columns in it.
strRow = CStr(in4Row)
.Range("I" & strRow & ":L" & strRow).ClearContents
NextRowToExamine:
Next in4Row
End With
End Sub
I have preferred clarity of code over efficiency.
Oct 31 2022 03:59 AM
Thank you @SnowMan55 that is exactly what I mean!
When I try to run this maco I get the following error:
error 1004 during execution:
ClearContents method of Range class failed
The following line gets highlighted
.Range("A" & strRowToCopy).EntireRow.Copy _
(.Range("A" & strNewLastRow))
What am i doing wrong?
Oct 31 2022 04:21 AM
Nov 05 2022 05:00 PM
@Martin01386 OK, I have made changes to:
Sub Martin()
' A response to this post:
' https://techcommunity.microsoft.com/t5/excel/excel-macro-formula-help/m-p/3665952
' Variables for values/objects that are determined once:
Dim objWorksheet As Worksheet
Dim in4FirstDataRow As Long
Dim in4InitialLastRow As Long
' Variables for interaction with the user:
Dim strMessage As String
Dim in4UserResponse As VbMsgBoxResult
' Variables for values that change for each row that is
' under examination:
Dim in4Row As Long
Dim strRow As String
Dim strColCValue As String
Dim strFormula As String
Dim in4MatchRelRow As Long
' Variables for values that may or may not change for each row:
Dim in4RowToPossiblyCopy As Long
Dim in4RowToCopy As Long
Dim strRowToCopy As String
Dim in4NewLastRow As Long
Dim strNewLastRow As String
'---- Identify the worksheet that will be modified. Get user
' confirmation.
Set objWorksheet = ActiveSheet
'
strMessage = "This Excel procedure is ready to modify worksheet " _
& objWorksheet.Name & vbCrLf & vbCrLf _
& "Click Cancel if that is not the correct worksheet " _
& ", and rerun this procedure AFTER you make the desired" _
& " worksheet active."
in4UserResponse = MsgBox(strMessage, vbExclamation Or vbOKCancel _
Or vbDefaultButton2)
If in4UserResponse = vbCancel Then Exit Sub
'---- Determine the first and last rows to work with. Again
' get user confirmation.
With objWorksheet
in4FirstDataRow = 2 '<<< You may need to change this value, _
or include code to calculate it, or prompt for it, _
depending on how your worksheet content is structured.
in4InitialLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
' -- Get user confirmation.
strMessage = "This procedure may modify data starting in row " _
& CStr(in4FirstDataRow) & " and add rows starting after row " _
& CStr(in4InitialLastRow) & vbCrLf & vbCrLf _
& "Click Cancel if that range of rows is not correct."
in4UserResponse = MsgBox(strMessage, vbExclamation Or vbOKCancel _
Or vbDefaultButton2)
If in4UserResponse = vbCancel Then Exit Sub
End With
'---- Other preparation:
in4NewLastRow = in4InitialLastRow
'---- The main processing:
With objWorksheet
For in4Row = in4FirstDataRow To in4InitialLastRow - 1
strRow = CStr(in4Row)
' Pick up the column C value in a row.
strColCValue = .Range("C" & strRow).Value
' Find any "duplicate" in the rows below it.
strFormula = "MATCH(""" _
& Replace(strColCValue, """", """""") _
& """, C" & CStr(in4Row + 1) _
& ":C" & CStr(in4InitialLastRow) _
& ",0)"
in4MatchRelRow = 0
On Error Resume Next
in4MatchRelRow = .Evaluate(strFormula)
On Error GoTo 0
If in4MatchRelRow = 0 Then
'...this row has no "duplicate" in column C
' among the original rows below it.
GoTo NextRowToExamine
End If
' Find any "duplicate" in the NEW rows. If found there,
' the proper row was copied while examining an earlier
' row with this duplicated value.
strFormula = "MATCH(""" _
& Replace(strColCValue, """", """""") _
& """, C" & CStr(in4InitialLastRow + 1) _
& ":C" & CStr(in4NewLastRow) _
& ",0)"
in4MatchRelRow = 0
On Error Resume Next
in4MatchRelRow = .Evaluate(strFormula)
On Error GoTo 0
If in4MatchRelRow > 0 Then
'...the duplicated value already has a new row.
GoTo ClearColumnsInThisRow
End If
'...We've found at least one "duplicate". Loop to
' locate the last among these "duplicates".
For in4RowToPossiblyCopy = in4InitialLastRow To _
(in4Row + in4MatchRelRow) Step -1
If StrComp(.Range("C" & in4RowToPossiblyCopy).Value _
, strColCValue, vbTextCompare) = 0 Then
'...a match; this is the one to copy.
in4RowToCopy = in4RowToPossiblyCopy
Exit For
End If
Next in4RowToPossiblyCopy
' -- Copy that row to the end of the data.
strRowToCopy = CStr(in4RowToCopy)
in4NewLastRow = in4NewLastRow + 1
strNewLastRow = CStr(in4NewLastRow)
.Range("A" & strRowToCopy).EntireRow.Copy Destination:= _
.Range("A" & strNewLastRow)
' -- Clear/change certain columns in the new row.
.Range("D" & strNewLastRow & ":G" & strNewLastRow) _
.ClearContents
.Range("H" & strNewLastRow).Value = _
.Range("C" & strRowToCopy).Value
ClearColumnsInThisRow:
' -- As this current row is NOT the last row (in the
' original range of rows) that has the "duplicate"
' column C value*, clear certain columns in it.
' * If it had been the last such "duplicate" row, the
' upper MATCH would not have found any "duplicate"
' beneath it.
.Range("D" & strRow).ClearContents
.Range("AC" & strRow & ":AD" & strRow).ClearContents
.Range("AG" & strRow).ClearContents
NextRowToExamine:
Next in4Row
End With
End Sub
I am also attaching the workbook I used for testing, now with an extra row of test data. Worksheet Martin2 is initially an exact copy of worksheet Martin01386, and Martin2 is the one I have been modifying (and refreshing) during the testing.
Nov 06 2022 01:55 AM
Oct 30 2022 02:42 PM
SolutionSome of your request is ambiguous.
So I believe you want:
...to become:
If I'm correct, consider this procedure (feel free to change the name). I expect it will work even if column C does not contain text.
Sub Martin()
Dim objWorksheet As Worksheet
Dim in4FirstDataRow As Long
Dim in4InitialLastRow As Long
Dim in4Row As Long
Dim strRow As String
Dim in4NewLastRow As Long
Dim strNewLastRow As String
'
Dim strColCValue As String
Dim strFormula As String
Dim in4MatchRelRow As Long
Dim in4RowToPossiblyCopy As Long
Dim in4RowToCopy As Long
Dim strRowToCopy As String
'----
Set objWorksheet = ActiveSheet '<<< If you want changes on the active worksheet, or...
Set objWorksheet = Sheets("Martin2") '<<< if you want changes on a specific worksheet
With objWorksheet
in4FirstDataRow = 2 '<<< You may need to change this value, or _
include code to calculate it.
in4InitialLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
in4NewLastRow = in4InitialLastRow
'
For in4Row = in4FirstDataRow To in4InitialLastRow - 1
strColCValue = .Range("C" & CStr(in4Row)).Value
strFormula = "MATCH(""" _
& Replace(strColCValue, """", """""") _
& """, C" & CStr(in4Row + 1) _
& ":C" & CStr(in4InitialLastRow) _
& ",0)"
in4MatchRelRow = 0
On Error Resume Next
in4MatchRelRow = .Evaluate(strFormula)
On Error GoTo 0
If in4MatchRelRow = 0 Then
'...this row has no "duplicate" in column C
' among the original rows below it.
GoTo NextRowToExamine
End If
' -- We've found at least one "duplicate".
' Locate the last among these "duplicates".
For in4RowToPossiblyCopy = in4InitialLastRow To _
(in4Row + in4MatchRelRow) Step -1
If StrComp(.Range("C" & in4RowToPossiblyCopy).Value _
, strColCValue, vbTextCompare) = 0 Then
'...a match; this is the one to copy.
in4RowToCopy = in4RowToPossiblyCopy
Exit For
End If
Next in4RowToPossiblyCopy
' -- Copy that row to the end of the data.
in4NewLastRow = in4NewLastRow + 1
strNewLastRow = CStr(in4NewLastRow)
strRowToCopy = CStr(in4RowToCopy)
.Range("A" & strRowToCopy).EntireRow.Copy _
(.Range("A" & strNewLastRow))
' -- Clear/change columns in the new row.
.Range("D" & strNewLastRow & ":G" & strNewLastRow) _
.ClearContents
.Range("H" & strNewLastRow).Value = _
.Range("C" & strRowToCopy).Value
' -- As this current row is NOT the last row that has
' the same column C value, clear columns in it.
strRow = CStr(in4Row)
.Range("I" & strRow & ":L" & strRow).ClearContents
NextRowToExamine:
Next in4Row
End With
End Sub
I have preferred clarity of code over efficiency.