I am trying to right code that will merge columns "D" through "L" when the number changes in column "M."
I have the following code, but all it does is merge every row from bottom up to row 2 regardless of value in column "M."
What am I missing???
Sub Merge_Upon_Change()
'Purpose: Merges cells between columns "D" and "L" when column "M" changes
Dim r As Long, i As Long
Application.DisplayAlerts = False 'Turn off windows warning popup
r = Cells(Rows.Count, "D").End(xlUp).row ' find last cell in Column D
For i = r To 2 Step -1
If Cells(i, 13).Value <> Cells(i + 13, 13).Value Then 'upon change in column M = 13
Range("D" & i & ":L" & i).Merge 'then merge column "D" through "L"
End If
Next i
Application.DisplayAlerts = True ''Turn on Windows warning popup
End Sub
Actually you have already made this question but to pretend this from being unanswered I am posting this answer for any future search about this question.
When you write your equation as M i <> M i+13 then it simply finds every equation True (because probably i+13 th row is not equal to your i th row) and hereby it merges everything from bottom to the 2nd row as your For loop is until 2
Sub Merge_Upon_Change()
'Purpose: Merges cells between columns "D" and "L" when column "M" changes
Dim r As Long, i As Long
Application.DisplayAlerts = False 'Turn off windows warning popup
r = Cells(Rows.Count, "D").End(xlUp).row ' find last cell in Column D
For i = r To 2 Step -1
If Cells(i, 13).Value <> Cells(i + 1, 13).Value Then 'upon change in column M = 13
Range("D" & i & ":L" & i).Merge 'then merge column "D" through "L"
End If
Next i
Application.DisplayAlerts = True ''Turn on Windows warning popup
End Sub
Related
Looking for some assistance programming a report. I'm in the early stages. I've hit a wall when attempting to conditionally subtract using VBA. I would like to Subtract 1 from Column C if Column B is greater than 1. Any assistance would be greatly appreciated. The code I have so far is below
Sub UniqueContactReport()
Columns("Z:AQ").EntireColumn.Delete
Columns("X").EntireColumn.Delete
Columns("V").EntireColumn.Delete
Columns("U").EntireColumn.Delete
Columns("J:S").EntireColumn.Delete
Columns("A:H").EntireColumn.Delete
Dim N As Long, i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = N To 1 Step -1
If Cells(i, "B") > 1 And Cells(i, "D") = 0 Then
Cells(i, "B").EntireRow.Delete
End If
Next i
End Sub
To succinctly address your question:
Sub ModifyColumnC()
Dim N As Long, i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row ' See comment below
For i = 1 to N 'no need to go backwards because you are not deleting
If Cells(i, "B").Value > 1 Then
Cells(i, "C").Value = Cells(i,"C").Value -1
End If
Next i
End Sub
I have added .Value simply because I try to avoid implicit code. But yes, .Value is the default behaviour. I have left the code that determines the end row because all the following rows are going to be blank (thus <1) and this saves processing time (potentially a lot of it).
An alternative piece of code to do exactly the same thing.
Sub ModifyColumnC()
Dim N As Long, i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 to N
Cells(i, "C").Value = Cells(i,"C").Value - IIf(Cells(i, "B").Value > 1,1,0)
Next i
End Sub
A nuance is that in the IIf command, all paths are evaluated. But in this case, both the true and false statements are simple constants and unlikely to raise any exceptions.
From your question it seems this is what you want.
Sub UniqueContactReport()
Columns("Z:AQ").EntireColumn.Delete
Columns("X").EntireColumn.Delete
Columns("V").EntireColumn.Delete
Columns("U").EntireColumn.Delete
Columns("J:S").EntireColumn.Delete
Columns("A:H").EntireColumn.Delete
Dim N As Long, i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = N To 1 Step -1
If Cells(i, "B") > 1 And Cells(i, "D") = 0 Then
debug.print Cells(i, "C").value - 1
End If
Next i
End Sub
you could make no loop and use AutoFilter():
Sub UniqueContactReport()
With Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row) 'reference column B cells from row 1 down to last not empty one
.AutoFilter field:=1, Criteria1:=">1" ' filter referenced range on their value being >1
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then ' if any filtered cell other then the header (first one)
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(, 1) ' reference filtered cells corresponding ones one colum to the right
.Value = .Value - 1 ' lower referenced cell value by one
End With
If .Cells(1, 1).Value > 1 Then .Cells(1, 2) = .cell(1, 2) - 1 ' check if first cell is to be treated, too (first cell of filtered range is assumed as the "header" so doesn't get caught in filter action)
End If
.Parent.AutoFilterMode = False ' remove autofilter
End With
End Sub
BTW you can collapse all those EntireColumn.Delete statements into one:
Range("Z1:AQ1,X1, V1, U1, J:S, A:H").EntireColumn.Delete
but in this case you have to properly adjust the columns reference in the list since columns get deleted in one shot i.e. what-you-list-is-what-gets-deleted while in your previous approach the order of the delete statements affects which original columns gets actually deleted
First I wish to check if the value in in each row of column D of "Sheet1" matches any row of column A of "Accepted". If there is a match, I would like to copy the value in column B of that row of "Sheet1" into column D of "Accepted".
However, as there are 2 possible values in column B of "Sheet1", I would like to split the values into two columns of "Accepted" - Columns D and E. Hence, the next loop, if the value in column D of "Accepted" is not "Restricted", then copy that value into Column E and remove content of Column D.
The code works fine in that it helps me to achieve my goal, however, the process is taking too long, and after some investigation I found out that the delay only occurs with the last loop. I was wondering if I could speed up this process, thanks!
Dim i As Long
Dim j As Long
Dim k As Long
'to speed up the VBA code
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
AcceptedLastRow = ActiveWorkbook.Worksheets("Accepted").Range("A" & Rows.Count).End(xlUp).Row
Sheet1LastRow = ActiveWorkbook.Worksheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row
For j = 1 To AcceptedLastRow
For i = 1 To Sheet1LastRow
If ActiveWorkbook.Worksheets("Sheet1").Cells(i, 4).Value = ActiveWorkbook.Worksheets("Accepted").Cells(j, 1).Value Then
ActiveWorkbook.Worksheets("Accepted").Cells(j, 4).Value = ActiveWorkbook.Worksheets("Sheet1").Cells(i, 2).Value
End If
Next i
Next j
'to transfer recognised status to the recognised column and to remove from restricted column
'I think this is the section which contributes to the lag/delay
Restrictedlastrow = ActiveWorkbook.Worksheets("Accepted").Range("D" & Rows.Count).End(xlUp).Row
For k = 9 To Restrictedlastrow
If ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Value <> "Restricted" Then
ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Copy ActiveWorkbook.Sheets("Accepted").Cells(k, 5)
ActiveWorkbook.Sheets("Accepted").Cells(k, 4).ClearContents
End If
Next k
'to reset settings back to normal
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Instead of
ActiveWorkbook.Sheets("Accepted").Cells(k, 4).Copy ActiveWorkbook.Sheets("Accepted").Cells(k, 5)
Use
ActiveWorkbook.Sheets("Accepted").Cells(k, 5) = ActiveWorkbook.Sheets("Accepted").Cells(k, 4)
Copy is an expensive operation. Since you seem to be interested only in a value of a cell, assign it directly (like you did in the previous loops).
Gods of VBA,
I would like to request your help on some code i can't seem to get working straight.
Purpose,
When a row has a cell Value "x" on row A in sheet 'Dump', i would like to past certain values in Sheet 'test'.
The values that need to be posted on Sheet 'test', are in column B, D, F and L.
Value from column B, Sheet 'Dump' should go to D4, in sheet 'test'.
Value from column D, Sheet 'Dump' should go to C4, in Sheet 'test'.
Value from column F, Sheet 'Dump' should go to A4, in Sheet 'test'.
Value from column L, Sheet 'Dump' should go to E4, in Sheet 'test'.
Ofcourse i'm trying to make the VBA loop as that when multiple rows on Sheet 'Dump' contains the character 'x', it continues from D/C/A/E4 to the next row.
The code I already have working is posted here:
Sub test()
Dim i, LastRow
LastRow = Sheets("Dump").Range("A" & Rows.Count).End(xlUp).Row
Sheets("test").Range("A2:K200").ClearContents
For i = 2 To LastRow
If Sheets("Dump").Cells(i, "A").Value = "x" Then
Sheets("Dump").Range(Cells(i, "B"), Cells(i, "B")).Copy
Destination:=Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub
Have been trying with a lot of different sources of VBA, and some tweaking to it. If i started with a wrong source, or am making some n00b-mistakes, please direct me to what i did wrong. Just trying to learn, while coding.
Tim posted the better way to copy values only but here is what is the problem with your code:
The syntax for copying is
sourceRange.Copy Destination:=destinationRange
The := specifies an option/paramter to the .Copy method. It can be confusing because there are no parentheses around the arguments like you could expect from other languages.
someMethod(argument1, argument2)
would be
someMethod argument1, argument2
if there is nothing else in the line (otherwise you need parentheses).
You can specify what argument you use by naming it and using :=. This is especially useful for optional arguments or to keep your code readable (you might not remember what each argument is in a few months). Some people keep parameters empty but I think it's obvious why something like
someMethod paramName1:=True, paramName4:=False, paramName5:=True
is easier to read than
someMethod True, , , False, True
(I am assuming the parameter names are descriptive like Destination).
The parameters of a function need to be in the same row as the function. To concatenate the rows, remove the linebreak (duh) or place an _ at the end of the line (if it get's to long).
Example with parentheses and linebreaks:
Set someRange = rangeToSearch.Find( _
What:="abc", _
LookIn:=xlValues, _
MatchCase:=True)
Example without parenthesis and linebreaks:
destinationRange.PasteSpecial Paste:=xlPasteValues, skipblanks:=True
You could try the following.
Sub test()
Dim i, LastRow
LastRow = Sheets("Dump").Range("A" & Rows.Count).End(xlUp).Row
Sheets("test").Range("A2:K200").ClearContents
j = 4
For i = 2 To LastRow
If Sheets("Dump").Cells(i, "A").Value = "x" Then
Sheets("test").Cells(j, 4) = Sheets("Dump").Cells(i, 2).Value
Sheets("test").Cells(j, 3) = Sheets("Dump").Cells(i, 3).Value
Sheets("test").Cells(j, 1) = Sheets("Dump").Cells(i, 6).Value
Sheets("test").Cells(j, 5) = Sheets("Dump").Cells(i, 12).Value
j = j + 1
End If
Next i
End Sub
You need a separate way of tracking each row in the test sheet, hence adding j = 4 (because you want to start on row 4).
EDIT
I would define your sheets if you call them a a lot.
Sub test()
Dim i, LastRow, source as Worksheet, dest as Worksheet
Set source = ActiveWorkbook.Sheets("Dump")
Set dest = ActiveWorkbook.Sheets("test")
LastRow = source.Range("A" & Rows.Count).End(xlUp).Row
dest.Range("A2:K200").ClearContents
j = 4
For i = 2 To LastRow
With source
If .Cells(i, "A").Value = "x" Then
dest.Cells(j, 4) = .Cells(i, 2).Value
dest.Cells(j, 3) = .Cells(i, 3).Value
dest.Cells(j, 1) = .Cells(i, 6).Value
dest.Cells(j, 5) = .Cells(i, 12).Value
j = j + 1
End If
End With
Next i
End Sub
I am trying to create a conditional loop macro in Excel. Column B contains a last name, Column C contains a first name, and Column D contains a first and last name. I am trying to get the macro to detect when Column D = Column C + Column B.
If D = C + B, then clear contents of D.
So, the following works for a single row:
Sub ClearContentsD ()
If Range("D1").Value = Range("C1").Value + Space(1) + Range("B1") Then Range("D1").ClearContents
End Sub
It does not work without the added Space(1), and I cannot get it to loop through the whole worksheet:
Sub ClearContentsLoop()
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Rows.Count
Next i
Do While Cells(i, 4).Value = Cells(i, 3).Value + Space(1) + Cells(i, 2).Value
Cells(i, 4).ClearContents
Loop
Application.ScreenUpdating = True
End Sub
VBA doesn't like my Do While. Any help would be greatly appreciated.
CJ
Some issues:
You must concatenate strings with &. The plus (+) is for addition;
Your For loop is not doing anything: its body is empty;
Your Do While Loop will at most run once, because i is not incremented;
It is a mystery why you would want two loops (For and Do While);
A sheet has many rows of which you only use a fraction, so don't loop through all of them (For) and use UsedRange.
Possible correction:
Sub ClearContentsLoop()
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 4).Value = Cells(i, 3).Value & " " & Cells(i, 2).Value Then
Cells(i, 4).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub
There is a way to ignore the space in the values you are evaluating. Try this:
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Rows.Count
If InStr(1, Cells(i, 4).Value, Cells(i, 2).Value, vbTextCompare) > 0 And InStr(1, Cells(i, 4).Value, Cells(i, 3).Value, vbTextCompare) > 0 Then Cells(i, 4).ClearContents
Next i
Application.ScreenUpdating = True
Explanation:
By using the InStr function, you are testing for the presence of one text string inside of another, and if at least one match is found, then the function returns a non-zero value (the position where the match was found). In the above example, you are testing for the presence of the first name and last name at the same time, and if both are found, then the code clears out the contents of the cell.
And, as was pointed out in the comments section, you need to do this inside the loop so that all cells down the length of the worksheet are evaluated and updated as specified.
Be sure to test this on a COPY of your original data so that you don't lose the original values in case you want to roll back your changes! ;)
I have been looking at how to develop a macro that deals with two columns - one holding a code for marriage status and the other relationship status. For example:
SI daughter
M wife
M husband
SI son
D mother
W father
M son
M wife
SI daughter
SI husband
SI stands for single, D for divorced, M for married, W for widowed, and so on.
The purpose of the macro is to test for mistakes, where a daughter or son cannot be other than single, and do that for about 1000 rows, and do so by evaluating the two adjacent cells in every row and returning the row that matches the criteria for a mistake. The mistakes above are that SI cannot be a Husband and M cannot be a Son.
For a single row, the following will do the job:
If Cells(2, 1).Value = "M" And Cells(2, 2).Value = "son" Then
MsgBox "You've found a mistake"
else
MsgBox "Keep checking"
End If
Doing the above for 1000 rows is impractical, so for the purpose of evaluating them, I came up with the following, but it does not work quite to specification:
Sub attempt9()
Dim i As Integer
Dim cell As Range
Dim cell2 As Range
Dim y As Range
Dim z As Range
Set y = Range("A1:A10")
Set z = Range("B1:B10")
For i = 1 To 10
For Each cell In y
cell.Offset(i, 0).Select
For Each cell2 In z
cell2.Offset(i, 0).Select
If cell.Offset(i, 0).Value = "M" And cell2.Offset(i, 0).Value = "husband" Then
Range("D1") = cell.Address & ", " & cell2.Address
End If
Next cell2
Next cell
Exit For
Next i
End Sub
The main issue I'm facing is how to get the loop to move the two adjacent cells row by row in lockstep and return the row or addresses of the erroneous cells. I've programmed the selections to move at the same iteration in both columns with every loop cycle, and so far, it will return the address of the cell with a value "M" in the first column, and the value of a cell with the value "husband" in the second column, but the rows will not match - and there is a strict IF AND condition for the purpose.
Try the following, you just need to use the loop variable to reference the row number and you can use a Select Case block to test all the error situations:
Dim error As Boolean
For i = 1 To 10
Select Case True
Case Cells(i, 1).Value = "M" And Cells(i, 2).Value = "son": error = True
Case Cells(i, 1).Value = "M" And Cells(i, 2).Value = "daughter": error = True
Case Cells(i, 1).Value = "SI" And Cells(i, 2).Value = "husband": error = True
'// repeat above for all error cases
Case Else: error = False
End Select
If error Then
MsgBox "You've found a mistake at row " & i
Exit For '// To stop the code and fix the error
End If
Next
MsgBox "Checking complete!"