Excel VBA: Compiler Errors - vba

So yesterday I posted my first SO question, and it went down like a ton of bricks. However I've picked myself up, dusted myself off, and hopefully this question will be more acceptable... :-)
I am trying to remove data duplicates from a list of Health Questionnaires I have to monitor, but the tricky bit I was struggling with was finding a duplicate in one column, AND then checking that the data on the same row, for the 3 adjacent columns were also duplicates. Storing the searched for 'duplicated row' was the bit that was throwing me off.
Here's some code I've cobbled together from other similarly-functioning scripts. I'm now in debug mode and keep getting errors thrown up... I don't have much experience of VBA, so i'm running out of options.
I'm currently getting type mismatch errors with the variable g, and also firstAddress. Why are these causing problems???
Can I call firstAddress.Row or am I barking up the wrong tree?
Here's the snippet:
g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
And here's the whole code below. Any help would be much appreciated!
Sub FindCpy()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet
Dim dupRow As Integer
Dim g As Integer
Dim firstAddress As Integer
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Used to narrow down the logical operators for duplicates
Dim rngFirst As Range
'Set the ranges
rngFirst = Range("G" & 1, "G" & lw)
Set sh = Sheets("Completed")
lw = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lw 'Find duplicates from the list.
If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
'if COMPLETE, check the rest of the sheet for any 'in progress' duplicates...
With Worksheets("Still In Progress").rngFirst
g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
If Range("H" & dupRow).Text = Range("H" & i).Text _
And Range("I" & dupRow).Text = Range("I" & i).Text _
And Range("J" & dupRow).Text = Range("J" & i).Text Then
'select the entire row
Range.EntireRow.Select
'copy the selection
Selection.Cut
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Completed")
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
'delete the initial row
rngCell.EntireRow.Delete
Set g = .FindNext(g)
Loop While Not g Is Nothing And g.Address <> firstAddress
End If
End With
Next i
End Sub

I went through your code carefully. There were a number of problems. Some of these I think I was able to fix - there was one where I guessed what you intended to do, but for one of them I just marked it; you need to explain what you were trying to do, as you are deleting a range that you never defined...
The first problem is with the line:
If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
The CountIf function returns a number; you are comparing this number with the string "Complete". I don't think you can ever get past this line, so the rest of the code (whether correct or not) will not execute. Not entirely clear what you are trying to do in this line, as I'm not sure when a line will be marked "Complete" - but assuming that you are interested in executing the rest of the code if the cell in A & i has the string "Complete" in it, then you probably want to do
If Range("A" & i).Text = "Complete" Then
There were a number of If - Then, With, and Loop structures that were not properly terminated with a matching End. I have tried to remedy this - make sure I did it right. Note that using proper indentation really helps to find problems like this. The space bar is your friend...
Since the Find method returns an object, the correct way to use the function is
Set g = .Find(Range("G" & i).Text, LookIn:=xlValues)
Apart from that - use Option Explicit at the top of your code, and define variables with the most restrictive (correct) type that you can. When I did this I found the error I could not correct - with the rngCell variable that was neither declared, nor ever set... It shows just how helpful it can be. Also good for catching typos - VBA will happily let you write things like
myVar = 1
MsgBox myVra + 1
The message will be 1, not 2, because of the typo... The fact that Explicit should even be an option is one of the many inexplicable design decisions made by the VBA team.
Here is your code "with most of the errors fixed". At least like this it will compile - but you must figure out what to do with the remaining error (and I can't be sure I guessed right about what you wanted to do with the cell marked "Complete").
Comments welcome.
Option Explicit
Sub FindCpy()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet
Dim dupRow As Integer
Dim g As Range
Dim firstAddress As Range
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Used to narrow down the logical operators for duplicates
Dim rngFirst As Range
'Set the ranges
rngFirst = Range("G" & 1, "G" & lw)
Set sh = Sheets("Completed")
lw = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lw 'Find duplicates from the list.
' If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
If Range("A" & i).Text = "Complete" Then
'if COMPLETE, check the rest of the sheet for any 'in progress' duplicates...
With Worksheets("Still In Progress").rngFirst
Set g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
If Range("H" & dupRow).Text = Range("H" & i).Text _
And Range("I" & dupRow).Text = Range("I" & i).Text _
And Range("J" & dupRow).Text = Range("J" & i).Text Then
'select the entire row
g.EntireRow.Select
'copy the selection
Selection.Cut
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Completed")
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
'delete the initial row
rngCell.EntireRow.Delete ' <<<<<< the variable rngCell was never defined. Cannot guess what you wanted to do here!
Do
Set g = .FindNext(g)
Loop While Not g Is Nothing And g.Address <> firstAddress
End If ' entire row matched
End If ' Not g Is Nothing
End With ' With Worksheets("Still in Progress")
End If ' CountIf = "Complete"
Next i
End Sub
Another handy trick: when you "paste in the next available row" as you are doing with Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select, I usually find it handy to do something like this instead:
Dim destination As Range
Set destination = Worksheets("Sheetname").Range("A1")
And when you need to paste something:
destination.Select
ActiveSheet.Paste
Set destination = destination.Offset(1,0)
This way, destination is always pointing to the "next place where I can paste". I find it helpful and cleaner.

Related

Why does Application.Match behave inconsistently when run multiple times on the same data?

The background:
I have a workbook, Outline.xlsm, with a five-level hierarchy. In the first worksheet (WS1), the first three levels are described the first two columns, while the next two levels each have their own set of two columns:
In the second worksheet (WS2), there is no level 3, but everything else is the same. All cells are formatted as text.
I have some code that splits out each first-level section ("General thing") into its own workbook to allow users to make changes to the descriptions (and some other fields off to the right). The code in question then goes out and gets those new descriptions from each file and matches them to the ID number. Here is a sanitized version:
Option Explicit
Sub GatherData()
'Set up for speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Get files to be processed
Dim DataFolder As String
Dim DataFile As String
DataFolder = "\\SomeNetworkLocation"
DataFile = Dir(DataFolder & "\GeneralThing*.xlsx")
'Define ranges to search
Dim WS1_L1Rng As Range
Dim L2rng As Range
Dim L3rng As Range
Set WS1_L1Rng = Worksheets("WS1").Range("A2", "A" & Range("N2").End(xlDown).Row)
Set L2rng = Worksheets("WS1").Range("C2", "C" & Range("N2").End(xlDown).Row)
Set L3rng = Worksheets("WS1").Range("E2", "E" & Range("N2").End(xlDown).Row)
Dim WS2_L1Rng As Range
Dim WS2_L2Rng As Range
Set WS2_L1Rng = Worksheets("WS2").Range("A2", "A" & Range("K2").End(xlDown).Row)
Set WS2_L2Rng = Worksheets("WS2").Range("C2", "C" & Range("K2").End(xlDown).Row)
Dim MatchPos As Variant
Dim WS1_SearchRng As Range
Dim WS2_SearchRng As Range
Dim Cell As Range
'Find and copy data
Do While DataFile <> ""
Workbooks.Open Filename:=DataFolder & "\" & DataFile
With Workbooks(DataFile).Worksheets("WS1")
Set WS1_SearchRng = .Range("A2:" & "A" & .Range("A" & .Rows.Count).End(xlUp).Row & ",C2:" & "C" & .Range("C" & .Rows.Count).End(xlUp).Row & ",E2:" & "E" & .Range("E" & .Rows.Count).End(xlUp).Row)
End With
For Each Cell In WS1_SearchRng
If IsNumeric(Left(Cell.Value2, 2)) Then
Select Case Cell.Rows.OutlineLevel
Case Is < 4
MatchPos = Application.Match(Cell.Value2, WS1_L1Rng, 0)
Case 4
MatchPos = Application.Match(Cell.Value2, L2rng, 0)
Case 5
MatchPos = Application.Match(Cell.Value2, L3rng, 0)
End Select
If IsError(MatchPos) Then
Debug.Print "WS1 " & Cell.Value2
Else
MatchPos = MatchPos + 1
Workbooks(DataFile).Worksheets("WS1").Range("A" & Cell.Row, "L" & Cell.Row).Copy Destination:=Workbooks("Outline.xlsm").Worksheets("WS1").Range("A" & MatchPos, "L" & MatchPos)
End If
End If
DoEvents
Next Cell
If Workbooks(DataFile).Worksheets.Count > 1 Then
With Workbooks(DataFile).Worksheets("WS2")
Set WS2_SearchRng = .Range("A2:" & "A" & .Range("A" & .Rows.Count).End(xlUp).Row & ",C2:" & "C" & .Range("C" & .Rows.Count).End(xlUp).Row)
End With
For Each Cell In WS2_SearchRng
If IsNumeric(Left(Cell.Value2, 2)) Then
Select Case Cell.Rows.OutlineLevel
Case Is < 4
MatchPos = Application.Match(Cell.Value2, WS2_L1Rng, 0)
Case 4
MatchPos = Application.Match(Cell.Value2, WS2_L2Rng, 0)
End Select
If IsError(MatchPos) Then
Debug.Print "WS2 " & Cell.Value2
Else
MatchPos = MatchPos + 1
Workbooks(DataFile).Worksheets("WS2").Range("A" & Cell.Row, "I" & Cell.Row).Copy Destination:=Workbooks("Outline.xlsm").Worksheets("WS2").Range("A" & MatchPos, "I" & MatchPos)
End If
End If
DoEvents
Next Cell
End If
With Workbooks(DataFile)
.Save
.Close
End With
DataFile = Dir
Loop
'Return to regular configuration
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
The problem:
Often, when I go to run this code, Application.Match throws an error when it tries to match to anything in WS2. It usually works fine if I just kill the execution and start over on the same data (sometimes it takes a few tries). Very rarely, it can't find anything in WS1 either; again, if I simply restart the execution it usually works just fine. Sometimes everything works great on the first try. Why does it not behave consistently?
Watch for implicit references to the active workbook/worksheet; what workbook/worksheet these instructions are referring to at run-time will depend on whatever workbook/worksheet is active at that time, and this is often responsible for such errors.
You can use Rubberduck (an open-source VBIDE add-in project I manage) to easily locate them for you (and other potential code issues).
Range("N2") in Worksheets("WS1").Range("A2", "A" & Range("N2").End(xlDown).Row) would be one. Worksheets used unqualified with a Workbook object would be another.
The solution is to explicitly qualify them with a Workbook or Worksheet object reference.

Delete Row If Cells Do Not Contain Values

I want to pass all cells in a certain range in column O and to delete all rows that do not contain values: OI and SI.
My code shows me an error at:
If Selection.Value <> "SI" Or "OI" Then
as a type mismatch
Sub CHECK()
Dim MFG_wb As Workbook
Dim Dep As Integer
Dim I As Integer
Set MFG_wb = Workbooks.Open _
("C:\Users\rosipov\Desktop\eliran\MFG - GSS\MFG Daily\Fast Daily " & Format(Now(), "ddmmyy") & ".xlsx", _
UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
MFG_wb.Sheets("Aleris").Activate
Dep = MFG_wb.Sheets("Aleris").Range("O2", Range("O2").End(xlDown)).Count
Range("O2").Select
For I = 1 To Dep
If Selection.Value <> "SI" Or "OI" Then
EntireRow.Delete
Else
Selection.Offset(1, 0).Select
End If
Next I
End Sub
Try this code to solve your problem. It not only fixes the problematic line, but it avoids some other pitfalls as well that will inevitably cause issues in the long run.
Sub CHECK()
Dim ManufacturingFile As Workbook
Set ManufacturingFile = Workbooks.Open _
("C:\Users\rosipov\Desktop\eliran\MFG - GSS\MFG Daily\Fast Daily " & Format(Now(), "ddmmyy") & ".xlsx", _
UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
Dim Aleris As Worksheet
Set Aleris = ManufacturingFile.Worksheets("Aleris")
Dim TotalRows As Long
TotalRows = Aleris.Range("O2", Aleris.Range("O2").End(xlDown)).Count
' Avoid Select at all costs
' Range("O2").Select
Dim i As Long
For i = TotalRows To 1 Step -1
If Aleris.Range("O" & i).Value <> "SI" And Aleris.Range("O" & i).Value <> "OI" Then
Aleris.Rows(i).Delete
End If
Next i
End Sub
First, your issue was caused by If Selection.Value <> "SI" Or "OI" Then because "OI" cannot be evaluated as a Boolean statement. Behind the scenes, the interpreter tried to convert "OI" to True or False but was unable to. As a result, you get an error. The fix is simple:
If Selection.Value <> "SI" or Selection.Value <> "OI" Then. Now we have two Boolean statements, both checking for equality. The interpreter is happy with this and can run just fine.
Beyond this, I fixed your unqualified range references, and your practice of Activate and Select. Despite some of the suggestions from others, both of these are very bad habits. Your code will break, and it will cost you. Don't believe me? Read pretty much any other post about Activate and Select and you'll see the same thing.
Why is this a bad idea? You have absolutely no control over what the ActiveSheet is during run-time. Sure you can Activate it, but there will be that time where something comes in and changes the focus to another sheet, and then you'll have issues. This one bug can literally cost hours of work if you're not careful.
The fix is simple. Just declare a variable (as you almost had), and use that variable. Voila! No more worrying about having the wrong sheet.
Finally, Excel is really good at understanding what you mean when you use indices to reference parts of the sheet. You don't have to Selection.Offset(1, 0).Select and then Selection.EntireRow.Delete since all this really means is ActiveSheet.Rows(Selection.Row + 1).Delete and we can refactor that further to use a worksheet, and an index to Foo.Rows(i + 1).Delete. See the pattern here? Become more abstract, step by step, until your code becomes solid.
The last thing I changed was your variable names. Use descriptive names, it makes your code easier to maintain. Also, never ever use underscores "_" in names until you understand Interfaces. Underscores have special meaning to the interpreter.
Finally, check out the Rubberduck project : rubberduckvba.com. It is a free add-in that is dedicated to improving the VBA coding experience. The best part? Most of this feedback is built into RD as inspections. It does the work for you, and you get to learn in the process.
Best of luck!
As Luuklag mentioned, start at the bottom. Also best get the xlLastCell (does not stop at blank cell) to count the rows and adjust the if statement to check for both SI and OI:
Dep = MFG_wb.Sheets("Aleris").Range("O2").SpecialCells(xlLastCell).Row
For I = Dep To 2 Step -1
Cells(I, 15).Select
If Not (Selection.Value = "SI" Or Selection.Value = "OI") Then
Rows(I).Delete
End If
Next I
Individual deleting row is slow.(This delete row many times, so it takes a long time to delete)
After merge range, delete merged range at once.(use Union method)
Sub CHECK()
Dim MFG_wb As Workbook
Dim Dep As Long
Dim i As Long '<~~ if your data is large then use long
Dim Ws As Worksheet
Dim s As String
Dim rngU As Range
Set MFG_wb = Workbooks.Open _
("C:\Users\rosipov\Desktop\eliran\MFG - GSS\MFG Daily\Fast Daily " & Format(Now(), "ddmmyy") & ".xlsx", _
UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
'MFG_wb.Sheets("Aleris").Activate
Set Ws = MFG_wb.Sheets("Aleris") '<~~ instead activate, use variable
With Ws
Dep = .Range("O2").End(xlDown).Row
'Range("O2").Select '<~~ select mothod is not goo.
For i = 2 To Dep
s = .Range("o" & i)
If s = "SI" Or s = "OI" Then
Else
If rngU Is Nothing Then
Set rngU = .Range("o" & i)
Else
Set rngU = Union(rngU, .Range("o" & i))
End If
End If
Next i
End With
If rngU Is Nothing Then
Else
rngU.EntireRow.Delete
End If
MFG_wb.Save
MFG_wb.Close (0)
End Sub
Just fix line
If Selection.Value <> "SI" Or "OI" Then
To
If Selection.Value <> "SI" Or Selection.Value<>"OI" Then
Once you activated sheet with MFG_wb.Sheets("Aleris").Activate you don't need to explicitly use it with Range objects. After mentioned line, the code should look like:
Dim s As Sheet
Set s = MFG_wb.Sheets("Aleris")
'determine last row in O column
Dep = s.Cells(s.Rows.Count, 15).End(xlUp).Row
For I = 1 To Dep Step -1
If InStr(1, s.Cells(I, 15).Value, "SI") + InStr(1, s.Cells(I, 15).Value, "OI") = 0 Then
s.Cells(I, 15).EntireRow.Delete
End If
Next I
Main reason for the change in a code you posted is that you are using Select method, which isn't a good practice. If you'd be interested, I advise you read why you should avoid using such funtions.

VBA Testing two values, if one is different, copy

I am having a fair amount of trouble with the code below:
Sub TestEmail()
Dim i As Long
Dim LastRow As Long
Dim a As Worksheet
Dim b As Worksheet
Dim strText
Dim ObjData As New MSForms.DataObject
Set a = Workbooks("Book2").Worksheets(1)
Set b = Workbooks("Book1").Worksheets(1)
LastRow = a.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If Not IsError(Application.Match(a.Cells(i, 7).Value, b.Columns(3), 0)) And IsError(Application.Match(a.Cells(i, 4).Value, b.Columns(11), 0)) Then
a.Range("D" & i).Copy
ObjData.GetFromClipboard
strText = Replace(ObjData.GetText(), Chr(10), "")
b.Range("K" & ).Value = b.Range("K" & ).Value & " / " & strText
End If
Next i
End Sub
I face two problems, one has me stumped and the other is due to lack of knowledge:
The line after IF is supposed to check if two values (numbers) in both workbooks match, and if two other values (text) don't match. If all true, then it must copy a value from Book2 and add it to a cell in book1.
The problems are:
-The macro doesn't seem to recognise when the values match or not.
-In the last line before "End If", I don't know how to tell excel to copy the text into the cell that didn't match in the second check.
I am sorry if I am not clear enough, this is hard to explain.
I'm hoping one of the experts knows how to make this work.
Thanks in advance
You are using If Not condition 1 And condition 2, so you are saying that if it doesn't match both conditions, Then you run the code. What you want to make are Nested If Statements However, one is If and the other If Not
To copy you are missing the i After "K"&: b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
The Address of the Cells are inside the Range Function, which in your case would be:
//It is the cell of the email from the first Workbook tou are copying, where you input the column D
a.Range("D" & i).Copy
//Add to Workbook b in column K the value from Cell K#/value copied
b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
You can also make it like this: b.Range("K" & i) = b.Range("K" & i).Value & " / " & a.Range("D" & i)
This way you are matching lines, so only if the IDs are on the same rows on both Workbooks it will work. If they aren't, you will have to use Nesting Loops or .Find Function
EDIT:
If I understood it, the code below might work if you make some changes for your application, because i didn't have the data to test and columns, etc. Try to implement it.
LastRowa = a.Cells(Rows.Count, "A").End(xlUp).Row
LastRowb = b.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRowa
'Address of String to look for
LookForString = a.Worksheets(1).Cells(i, 4) '4 is the COLUMN_INDEX
'Range to look on Workbook a
With a.Worksheets(1).Range("D1:D" & LastRowa) 'choose column to look
'Function .Find String on book a
Set mail_a = .Find(LookForString, LookIn:=xlValues)
If Not mail_a Is Nothing Then
FirstAddress = mail_a.Address
Do ' Actions here
'Range to look on Workbook b
With b.Worksheets(1).Range("K1:K" & LastRowb) 'choose column to look
'Function .Find on Workbook b
Set mail_b = .Find(LookForString, LookIn:=xlValues)
If Not mail_b Is Nothing Then
FirstAddress = mail_b.Address
Do 'Actions
'Verify if two other values (text) don't match
If Not WRITE_MATCH_CONDITION_HERE Then
'No need to verify of they are equal because the .Find function used the same reference
'I will use .Cells with .Row and .Column just to show another way to do it and make it dynamic
b.Cells(mail_b.Adress.Row, mail_b.Adress.Column) = b.Cells(mail_b.Adress.Row, mail_b.Adress.Column).Value & " / " & a.Cells(mail_a.Adress.Row, mail_a.Adress.Column) 'choose columns
End If
Set mail_b = .FindNext(mail_b)
Loop While Not mail_b Is Nothing And mail_b.Address <> FirstAddress
End If
End With
Set mail_a = .FindNext(mail_a)
Loop While Not mail_a Is Nothing And mail_a.Address <> FirstAddress
End If
End With
Next i
End Sub
p.s.: The <> is missing on mail_a.Address <> FirstAddress and mail_b.Address <> FirstAddress, when i posted with

VBA-Excel Look for column names, return their number and use column letters in function

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

Application defined or object defined error on code

I get an error on this line in my code, any ideas what the issue may be?
Intersect(.UsedRange, .UsedRange.Offset(1)).SpecialCells(12).EntireRow.Delete
Here is the rest of the code:
Sub DefineDL_IDL()
Dim wbTHMacro As Workbook, wsRegulares As Worksheet, wsRegularesDemitidos As Worksheet, wsTempActivos As Worksheet, _
wsTempJA As Worksheet, wsTempFit As Worksheet, wsTempDemitidos As Worksheet, wsPS As Worksheet, wsResultados As Worksheet, _
wsDLList As Worksheet, wssheet As Worksheet, count_DL As Integer, count_IDL As Integer
Dim x&, r As Long
'*************REGULARES***********
Sheets("Regulares").Select
'Debug.Print xlToRight
'Sheets("Raw").Copy before:=Sheets(2)
With Sheets("Regulares")
'.Name = "Final2"
.UsedRange.AutoFilter 9, "INATIVE"
Intersect(.UsedRange, .UsedRange.Offset(1)).SpecialCells(12).EntireRow.Delete
r = WorksheetFunction.CountA(.Range("A:A"))
.UsedRange.AutoFilter
.Range("J:J").Insert xlToRight
.Range("J1").Value = "Real MO"
.Range("K:K").Cut
.Range("I:I").Insert xlToRight
.Range("Q:Q").Cut
.Range("I:I").Insert xlToRight
.Range("L2:L" & r).FormulaR1C1 = "=VLOOKUP(RC[-3],'DL List'!C[-11]:C[-10],2,0)"
.Range("L2:L" & r).Value = .Range("L2:L" & r).Value
For x = 2 To r
If Range("L" & x).Text = "#N/A" Then
'If Range("K" & x).Value = "DL" Then
' Range("L" & x).Value = "DL"
'Else: Range("L" & x).Value = "IDL": End If
Range("L" & x).Value = "IDL"
End If
Next x
End With
count_DL = Application.WorksheetFunction.CountIf(ActiveSheet.Range("L:L"), "DL")
count_IDL = Application.WorksheetFunction.CountIf(ActiveSheet.Range("L:L"), "IDL")
Worksheets("Resultados").Range("B17") = count_DL
Worksheets("Resultados").Range("C17") = count_IDL
Your expression works on my test worksheet so the problem must be something about your data.
I do not like stringing properties together like this because the objective becomes very unclear. Worse, if it fails, you do not know where is fails.
Try replacing the statement with this:
Dim rng As Range
Debug.Print .UsedRange.Address
Debug.Print .UsedRange.Offset(1).Address
Set rng = Intersect(.UsedRange, .UsedRange.Offset(1))
Debug.Print rng.Address
Debug.Print rng.SpecialCells(12).Address
Debug.Print rng.SpecialCells(12).EntireRow.Address
rng.SpecialCells(12).EntireRow.Delete
Step through this code to make sure each range is as you expect.
My guess that that there are no visible cells in the range so you are attempting to delete Nothing.
Edit Extra information about finding last row of worksheet.
There are a variety of methods of finding the last used row or column of a worksheet. None work in every situation but UsedRange is the method least likely to give the result you expect.
The most popular method of finding the last row, judging by answers here, is:
RowLast = .Cells(Rows.Count,9).End(xlUp).Row
This is the VBA equivalent of placing the cursor in the bottom cell of column 9 and clicking Ctrl+Up. RowLast will be set to the last row with a value in column 9 unless you have a value in the bottom cell. For this method to be of any use, there must be a value in the specified column of the last used row.
Find is a reliable method of finding the last value by either row or column.
SpecialCells is another useful method.
This answer of mine VBA Dynamic Ranges includea a macro, FindFinal, which demonstrates how these methods can fail to give the result you might expect. If you wish to fully understand the issues, step through this macro studying what happens.