I have 3 columns A,B & C. The data is in B & C. I filter Column C to show "Unique records only". Now I want to add serial numbers to this filtered data in Column A. Be advised that the number of rows in the list (and therefore the filtered list) is not fixed.
I know the function (=SUBTOTAL(3,$B$1:B2)-1 ) but this requires manual intervention. I also found the VBA code that works on an unfiltered list:
Sub FillSerialNumbers()
With Range("A3:A" & Range("B" & Rows.Count).End(xlUp).Row)
.Cells(1, 1).Value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With
End Sub
However I'm unable to implement it on a filtered list. Any help would be appreciated.
Here is another way
Set rRng = Range("A3:A" & Range("B" & Rows.Count).End(xlUp).Row)
Dim cntr As Integer: cntr = 1
For Each cell In rRng
If cell.EntireRow.Hidden = False Then
Cells(cell.Row, 1).Value = cntr
cntr = cntr + 1
End If
Next
As a formula solution, you could try, in cell A3 and copied down:
=IF(AND(COUNTIF(C$3:C3,C3)=1,C3<>""),max(A$2:A2)+1,"")
Related
All I am trying to populate a listbox with a For Each loop which iterates through the rows. The for each loop is going through the items in a Named range (ProgramIDs).
The current code I am using is
If Len(ProjectInformation.Range("H2").Value) = 7 Then
Dim Lr As Long
Lr = Range("H1048576").End(xlUp).Row
For Each C In Range("H2:H" & Lr)
With Program_ListBox
.AddItem C.Value
End With
Next C
End If
I fear this is a very basic question however after researching the website / google I simply cannot get this simple task to function.
Any help would be appreciated.
There is no need to loop, you can pass the range as the source of the listbox
Program_ListBox.List = Range("H2:H" & Lr)
Range("H2:H" & Lr) references the cells on the ActiveSheet. You should always fully qualify your references.
With ProjectInformation
If Len(.Range("H2").Value) = 7 Then
For Each C In .Range("H2", .Range("H" & .Rows.Count).End(xlUp))
With Program_ListBox
.AddItem C.Value
End With
Next C
End If
End With
There is no need loop the cells to the add the values to the listbox. You can assign the Range().Value array directly to the Listbox.List array.
With ProjectInformation
If Len(.Range("H2").Value) = 7 Then
Program_ListBox.List = .Range("H2", .Range("H" & .Rows.Count).End(xlUp)).Value
End If
End With
I'm quite new at VBA. I've used it in excel for a couple macros, but this one is way above my head.
I'm looking to create a macro that will find the appropriate column, then based on the value in this columns, changes the values in three other columns. I already have a static macro:
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
lastrow = Range("AE" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range("AE" & i).Value) Then
If Range("AE" & i).Value = "No" And Range("U" & i).Value = "MEM" Then
Range("U" & i).Value = "C-MEM"
Range("Y" & i).ClearContents
Range("AJ" & i).Value = "N/A"
ElseIf Range("AE" & i).Value = "No" And Range("U" & i).Value = "VCH" Then
Range("U" & i).Value = "C-VCH"
Range("Y" & i).ClearContents
Range("AJ" & i).Value = "N/A"
End If
End If
Next i
End Sub
But this is a shared workbook, so people are adding columns randomly and every time I need to go back to the code and modify the columns refereces. What I want is, for instance, to look for column with "Role" header in row A3 and to insert it where the macro looks for column "U". That way other users can add/delete columns but I won't have to modify the macro every time.
In other macros, I manage to have this thing working:
Function fnColumnNumberToLetter(ByVal ColumnNumber As Integer)
fnColumnNumberToLetter = Replace(Replace(Cells(1,ColumnNumber).Address, "1", ""), "$", "")
End Function
Dim rngColumn As Range
Dim ColNumber As Integer
Dim ColName As String
ColName = "Email Address"
Sheets("Tracking").Select
Set rngColumn = Range("3:3").Find(ColName)
ColNumber = Sheets("Tracking").Range(rngColumn, rngColumn).Column
Sheets("Combined").Range(ActiveCell, "W2").FormulaLocal = "=IF(ISERROR(INDEX(Tracking!$A:$A,MATCH(O:O,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0))), INDEX(Tracking!$A:$A,MATCH(U:U,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0)), INDEX(Tracking!$A:$A,MATCH(O:O,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0)))"
However, I am unable to link the latter to the first and much less to get it to find multiple columns. Any help is appreciated.
EDIT:
Following suggestions, here is the new code. Doesn't return an error, but doesn't do anything either. It loops through the c loop ok, but jumps from For i =2 ... line to End Sub.
Sub Adjust()
Dim lastrow As Long
Dim i As Long
Dim headers As Dictionary
Dim c As Long
Set headers = New Scripting.Dictionary
For c = 1 To Cells(3, Columns.Count).End(xlToLeft).Column
headers.Add Cells(3, c).Value, c
Next c
lastrow = Cells(headers.Item("Survey: Interest to Participate") & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Cells(i, headers.Item("Survey: Interest to Participate")).Value) Then
If Cells(i, headers.Item("Survey: Interest to Participate")).Value = "No" And Cells(i, headers.Item("Role")).Value = "MEM" Then
Cells(i, headers.Item("Role")).Value = "C-MEM"
Cells(i, headers.Ittem(" Follow-up date")).ClearContents
Cells(i, headers.Item("REV profile follow-up date")).Value = "N/A"
ElseIf Cells(i, headers.Item("Survey: Interest to Participate")).Value = "No" And Cells(i, headers.Item("Role")).Value = "VCH" Then
Cells(i, headers.Item("Role")).Value = "C-VCH"
Cells(i, headers.Ittem(" Follow-up date")).ClearContents
Cells(i, headers.Item("REV profile follow-up date")).Value = "N/A"
End If
End If
Next i
End Sub
The way I'd go about this would be to create a Dictionary with header names as keys and column numbers as values:
Dim headers As Dictionary
Set headers = New Scripting.Dictionary
Dim c As Long
'Assuming headers are in row 1 for sake of example...
For c = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
headers.Add Cells(1, c).Value, c
Next
Then, instead of using hard-code column letters with the Range, use the Cells collection and index it by column number using the Dictionary to look it up based on the header. For example, if your code expects column "U" to be under that header "Role" here:
Range("U" & i).Value = "C-MEM"
You can replace it with a column lookup like this using the Dictionary like this:
Cells(i, headers.Item("Role")).Value = "C-MEM"
Note that this requires a reference to the Microsoft Scripting Runtime (Tools->References... then check the box).
But this is a shared workbook, so people are adding columns randomly and every time I need to go back to the code and modify the columns refereces.
Protect the workbook to prevent this undesired behavior?
I would personally prefer to use Named Ranges, which will adjust with insertions and re-sorting of the data columns.
From Formulas ribbon, define a new name:
Then, confirm that you can move, insert, etc., with a simple procedure like:
Const ROLE As String = "Role"
Sub foo()
Dim rng As Range
Set rng = Range(ROLE)
' This will display $B$1
MsgBox rng.Address, vbInformation, ROLE & " located:"
rng.Offset(0, -1).Insert Shift:=xlToRight
' This will display $C$1
MsgBox rng.Address, vbInformation, ROLE & " located:"
rng.Cut
Application.GoTo Range("A100")
ActiveSheet.Paste
' This will display $A$100
MsgBox rng.Address, vbInformation, ROLE & " located:"
End Sub
So, I would define a Named Range for each of your columns (presently assumed to be AE, U, Y & AJ). The Named Range can span the entire column, which will minimize changes to the rest of your code.
Given 4 named ranges like:
Role, representing column U:U
RevProfile, representing column AJ:AJ
FollowUp, representing column Y:Y
Intent, representing column AE:AE
(NOTE: If you anticipate that users may insert rows above your header rows, then I would change the Named range assignments to only the header cells, e.g., "$AE$1", "$U$1", etc. -- this should require no additional changes to the code below)
You could do like this:
'Constant strings representing named ranges in this worksheet
Public Const ROLE As String = "Role"
Public Const REVPROFILE As String = "RevProfile"
Public Const FOLLOWUP As String = "FollowUp"
Public Const INTENT As String = "Intent"
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
lastrow = Range(INTENT).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range(INTENT).Cells(i).Value) Then
If Range(INTENT).Cells(i).Value = "No" And Range(ROLE).Cells(i).Value = "MEM" Then
Range(ROLE).Cells(i).Value = "C-MEM"
Range(FOLLOWUP).ClearContents
Range(REVPROFILE).Cells(i).Value = "N/A"
ElseIf Range(INTENT).Cells(i).Value = "No" And Range(ROLE).Cells(i).Value = "VCH" Then
Range(ROLE).Cells(i).Value = "C-VCH"
Range(FOLLOWUP).Cells(i).ClearContents
Range(REVPROFILE).Value = "N/A"
End If
End If
Next
End Sub
I would go with David Zemens answer but you could also use Range().Find to get the correct columns.
Here I refactored you code to find and set references to your column headers. Everything is based relative to these references.
Here I set a reference to Row 3 of the Survey column where your column header is:
Set rSurvey = .Rows(3).Find(What:="Survey", MatchCase:=False, Lookat:=xlWhole)
Because everything is relative to rSurvey the last row is = the actual last row - rSurvey's row
lastrow = rSurvey(.Rows.Count - rSurvey.Row).End(xlUp).Row - rSurvey.Row
Since rSurvey is a range we know that rSurvey.Cells(1, 1) is our column header. What isn't apparent is that since rSurvey is a range rSurvey(1, 1) is also our column header and since column and row indices are optional rSurvey(1) is also the column header cell.
Know all of that we can iterate over the cells in each column like this
For i = 2 To lastrow
rSurvey( i )
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
Dim rRev As Range 'AJ
Dim rRole As Range 'U
Dim rFollowUp As Range 'Y
Dim rSurvey As Range 'AE
With Worksheets("Tracking")
Set rRev = .Rows(3).Find(What:="REV", MatchCase:=False, Lookat:=xlWhole)
Set rRole = .Rows(3).Find(What:="Role", MatchCase:=False, Lookat:=xlWhole)
Set rFollowUp = .Rows(3).Find(What:="Follow-up", MatchCase:=False, Lookat:=xlWhole)
Set rSurvey = .Rows(3).Find(What:="Survey", MatchCase:=False, Lookat:=xlWhole)
lastrow = rSurvey(.Rows.Count - rSurvey.Row).End(xlUp).Row - rSurvey.Row
End With
For i = 2 To lastrow
If Not IsError(rSurvey(i).value) Then
If rSurvey(i).value = "No" And rRole(i).value = "MEM" Then
rRole(i).value = "C-MEM"
rFollowUp(i).ClearContents
rRev(i).value = "N/A"
ElseIf rSurvey(i).value = "No" And rRole(i).value = "VCH" Then
rRole(i).value = "C-VCH"
rFollowUp(i).ClearContents
rRev(i).value = "N/A"
End If
End If
Next i
End Sub
I'm very new to macros (it's been a few days now!) but slowly working my way through. I'd like to create a macro that adds a value of 2 to a cell if column D contains the text "(2)" AND column AG contains the text "Adult".
I've created a macro that so far changes the value of the cell to 5 (instead of adding to it) if column D contains the text "(2)" - I've spent a while messing around with "And" functions but I can't seem to find a way to make it take into account the both the "(2)" text in the D column and the "Adult" text in the AG column (I can only make it search one or the other).
Here's my attempt (this doesn't include any of my failed attempts to include the "Adult" text):
Sub BUBFindGuests()
Dim SrchRng As Range
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Set SrchRng = Range("D1:D" & lastRow, "AG1:AG" & lastRow)
For Each cel In SrchRng
If InStr(1, cel.Value, "(2)") > 0 Then
With cel.Offset(0, 39)
.Offset(-1, 0) = "5"
End With
End If
Next cel
End Sub
I'm basically just trying to work out how to include the "Adult" text from the AG column, and also how to make the macro add rather than change the end value. I'm also relatively certain that some parts of my code are unnecessary or clunky, but with my level of experience I'm unsure of how to correct that. Any help would be much appreciated.
Judging by your code, you want to add 2 to column C, if that's the case this should do the trick:
Sub BUBFindGuests()
lastRow = Sheets("SHEETNAME").Range("D" & Rows.Count).End(xlUp).Row
For x = 1 to lastRow
If InStr(1, Sheets("SHEETNAME").Cells(x, 4), "(2)") <> 0 _ 'Checks column D
And Instr(1, Sheets("SHEETNAME").Cells(x, 33), "Adult") <> 0 Then 'Checks column AG
Sheets("SHEETNAME").Cells(x, 3).Value = _
Sheets("SHEETNAME").Cells(x, 3).Value + 2 'Change 3 to the appropriate column
End If
Next x
End Sub
You can search for Adult just as you searched for the (2). Just use the InStr-function two times and combine the result-booleans. You can do that in two ways, logical with And or nested with two if-statements:
If InStrResult1 **And** InStrResult2 Then 'do stuff End If
If InStrResult1 Then If InStrResult2 Then 'do stuff End If End If
Sorry for the bad formation.
You can then store the current value of your cell in a variable. Then add 2 to that variable (myVariable = myVariable + 2) and then set its value to your cell instead of 5.
EDIT: It turns out I misread your question. See revised code.
Sub BUBFindGuests()
Dim SrchRng As Range
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Set SrchRng = Range("D1:D" & lastRow, "AG1:AG" & lastRow)
For Each cel In SrchRng
If InStr(1, cel.Value, "(2)") > 0 And InStr(1, cel.Value, "Adult") > 0 Then cel.Offset(-1, 39).Value = .Offset(-1, 0).Value & "5"
Next cel
End Sub
I need your help please, I have 4 columns in an excel sheet and I need to compare them 2 by 2 i will explain to you :
In column A i have users(user1,user2,user3 ...)
In column B i have functionalities ( fonc1, fonc2, fonc3.....)
In column C i have users(user1,user2,user3 ...)
In column D i have functionalities ( fonc1, fonc2, fonc3.....)
The columns C and D are a new version of columns A and B in the columns C and D the users may change order or change functionalities .
When i execute my code i put the result in other new columns:
column F where i have the users
column G where i put the Deleted_functionalities
column H where i put the New_functionalities
The first problem is that the code doesn't get the users it get only the new and deleted functionalities. The second problem is that when the column A is more than column C where the users are stocked the code doesn't work. Can you please help me to find a solution? Thank you in advance .
Here is my code and the file I am working on :
Private Sub CommandButton2_Click()
Dim rngCell As Range
For Each rngCell In Range("B2:B2000")
If WorksheetFunction.CountIf(Range("D2:D2000"), rngCell) = 0 Then
Range("G" & Rows.Count).End(xlUp).Offset(1) = rngCell
End If
Next
For Each rngCell In Range("D2:D2000")
If WorksheetFunction.CountIf(Range("B2:B2000"), rngCell) = 0 Then
Range("H" & Rows.Count).End(xlUp).Offset(1) = rngCell
End If
Next
End Sub
and this is the excel file
http://www.cjoint.com/c/FCxnwjp22rv
try this
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim cell As Range, funcCell As Range
Dim oldUserRng As Range, newUserRng As Range, reportRng As Range
Dim iReport As Long
Dim oldFunc As String, newFunc As String
Set ws = ThisWorkbook.Worksheets("users") '<== adapt it to your needs
With ws
Set oldUserRng = .Columns(1).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeConstants, xlTextValues)
Set newUserRng = .Columns(3).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeConstants, xlTextValues)
Set reportRng = .Range("F1:I1") '<== added one report column to account for unchanged functions
End With
reportRng.Value = Array("user", "deleted", "new", "same")
iReport = 1
For Each cell In oldUserRng
With cell
oldFunc = .Offset(, 1).Value
Set funcCell = FindAndOffset(newUserRng, .Value, 1)
If funcCell Is Nothing Then
reportRng.Offset(iReport) = Array(.Value, "", "", oldFunc)
Else
newFunc = funcCell.Value
If newFunc = oldFunc Then
reportRng.Offset(iReport) = Array(.Value, "", "", newFunc)
Else
reportRng.Offset(iReport) = Array(.Value, oldFunc, newFunc, "")
End If
End If
iReport = iReport + 1
End With
Next cell
For Each cell In newUserRng
With cell
Set funcCell = FindAndOffset(oldUserRng, .Value, 1)
If funcCell Is Nothing Then
reportRng.Offset(iReport) = Array(.Value, "", .Offset(, 1).Value, "")
iReport = iReport + 1
End If
End With
Next cell
End Sub
Not so sure it does what you need.
you'd better provide screenshots of "before" and "after" scenarios.
BTW, is it safe to assume that both old and new user columns cannot hold duplicates (i.e.: two or more "userX" in column A and/or column C?)
But it does speed up thing considerably since it iterates only through non empty cells.
I hope I get what you want to achieve. Does the following solve your problem?
Private Sub CommandButton2_Click()
Dim rngCell As Range
For Each rngCell In Range("A2:A20000")
If WorksheetFunction.CountIf(Range("C2:C20000"), rngCell) > 0 Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 1) = rngCell.Offset(0, 1).Value
Range("F" & Rows.Count).End(xlUp).Offset(0, 2) = Application.WorksheetFunction.VLookup(rngCell.Value, Range("C2:D20000"), 2, 0)
ElseIf (rngCell <> "") Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 1) = rngCell.Offset(0, 1).Value
End If
Next
For Each rngCell In Range("C2:C20000")
If (WorksheetFunction.CountIf(Range("A2:A20000"), rngCell) = 0 And rngCell <> "") Then
Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
Range("F" & Rows.Count).End(xlUp).Offset(0, 2) = rngCell.Offset(0, 1).Value
End If
Next
End Sub
A user is only included in column F when he appears both in columns A and C.In case you want to include every user that is either in column A or C the code has to be altered.
I have a sheet with multiple data in 1 cell this happen in a couple of columns. What I need to do is split the cell into individual rows while still keep the details from the other columns
Screen 1 shows the data i got
http://imageshack.com/a/img845/1783/wxc8.png (Screen 1)
Screen 2 is what i wish the macro to output.
http://imageshack.com/a/img842/7356/7yra.png (screen 2)
The macro i found and edited in only allows me to split 1 column and i can't get the editing of the range right. the columns that needs to be split is "J" "K" "N" and "O". The columns "A"- "I" and "L""M" just needs to copy their content to the new row.
Thank you in advance for the help.
Here the Macro im using
Sub Splt1()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("J" & Rows.Count).End(xlUp).Row
Columns("J").Insert
For i = LR To 1 Step -1
With Range("K" & i)
If InStr(.Value, Chr(10)) = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, Chr(10))
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("K").Delete
LR = Range("J" & Rows.Count).End(xlUp).Row
With Range("L1:M" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
The problem appears to be the with operator. It constrains your selection. Try reformulating your macro without the with and refer to the the ranges direct. For example, replace your first for loop with something like this:
For i = LR To 1 Step -1
If InStr(Range("K" & i).Value, Chr(10)) = 0 Then
Range("K" & i).Offset(, -1).Value = Range("K" & i).Value
'Range("J" ...
'Range("N" ...
'Range("O" ...
Else
K_collection = Split(Range("K" & i).Value, Chr(10))
Range("K" & i).Offset(1).Resize(UBound(K_collection)).EntireRow.Insert
Range("K" & i).Offset(, -1).Resize(UBound(K_collection) - LBound(K_collection) + 1).Value = Application.Transpose(K_collection)
'J_collection = Split(Range("J"...
'N_collection = Split(Range("N"...
'O_collection = Split(Range("O"...
End If
Next i
In general I avoid with because it tends to obscure the visual pattern of code.
You might also consider eliminating the .INSERT and .DELETE columns, and overwrite directly to the cells. When working with more than one at a time, it becomes hard to keep track which column is temporary and which one is the source. But that all depends on your preference.
Copying values for the other columns should be easy compared to this.