Find column based on column header - excel

I have this code and it only works if the header I'm looking for is in column B or "higher".
Lets say I have this table and need to find what column "Name" and "score" is in.
Name score
John 1
Joe 5
If "Name" is in B1 and "score" is in C1 the following code will work:
NameColumn = Split(Cells(1, Cells(1, 1).EntireRow.Find(What:="Name", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, searchdirection:=xlNext, MatchCase:=True).Column).Address(True, False), "$")(0)
ScoreColumn = Split(Cells(1, Cells(1, 1).EntireRow.Find(What:="score", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, searchdirection:=xlNext, MatchCase:=True).Column).Address(True, False), "$")(0)
^^ <- search value
The above code would in the case return
NameColumn = "B"
ScoreColumn = "C"
But suppose the columns are A & B then it will not find "Name" because it starts searching after cell 1,1 (A1) which is where the header is.
What can I change to make this work, or what alternatives are there to returning "A" and "B" in the example above?

Here is a quick UDF function that i have used in the past.
This may not be the best way to do it, but this is one I have used for many years.
Function ColumnHeaderLocation(entry As String, Optional ColumnNumber As Boolean)
Dim x, y As Long
y = ActiveSheet.Columns.Count
x = 1
Do Until x > y
If ActiveSheet.Cells(1, x).Value = entry Then
ColumnHeaderLocation = Split(ActiveSheet.Cells(1, x).Address(True, False), "$")(0)
If ColumnNumber = True Then ColumnHeaderLocation = x
Exit Function
Else
x = x + 1
End If
Loop
End Function
Simply use the name of the column header (see example)...
NameColumn = ColumnHeaderLocation("Name") ' returns Column Location as a letter
Or
NameColumn = ColumnHeaderLocation("Name", True) ' Returns column Location as a Number

Header Column Letter Calculation
You will have to add the After argument to the Find method pointing to the last cell .Cells(.Cells.Count) to start the search from the first cell .Cells(1). But as chris neilsen in the comments pointed out, this is not the reason your code would fail, because it would find Name at the end of the search.
Since you haven't defined what 'not working' actually means, and it is highly unlikely that you have misspelled Name in A1, I would assume that NameColumn returns an undesired result (<>A) meaning that you have used Name somewhere else in the first row and you really need to start the search from the first cell .Cells(1).
Short Version
Sub FindAfterShort()
Dim NameColumn As String ' Name Column Letter
Dim ScoreColumn As String ' Score Column Letter
With Rows(1)
NameColumn = Split(.Find("Name", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
ScoreColumn = Split(.Find("Score", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
End With
Debug.Print "Column Letters '" & NameColumn & "' and '" & ScoreColumn & "'."
End Sub
Preferable Version
Sub FindAfterPref()
Const cSheet As String = "Sheet1" ' Worksheet Name
Dim strName As String ' Name Column Letter
Dim strScore As String ' Score Column Letter
With ThisWorkbook.Worksheets(cSheet).Rows(1)
strName = Split(.Find("Name", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
strScore = Split(.Find("Score", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
End With
Debug.Print "Column Letters '" & strName & "' and '" & strScore & "'."
End Sub
A Small Study
Sub FindAfter()
Const cSheet As String = "Sheet1" ' Worksheet Name
Const cFR As Long = 2 ' First Row
' The column where the Last Row Number will be calculated.
Const cLRColumn As Variant = "A" ' Last-Row Column Letter/Number
Dim rngName As Range ' Name Column Range, Name Range
Dim rngScore As Range ' Score Column Range, Score Range
Dim lngName As Long ' Name Column Number
Dim lngScore As Long ' Score Column Number
Dim strName As String ' Name Column Letter
Dim strScore As String ' Score Column Letter
Dim lngLR As Long ' Last Row Number (Calculated in Last-Row Column)
With ThisWorkbook.Worksheets(cSheet).Rows(1)
' Find Method Arguments
' 2. After: If you want to start the search from the first cell, you
' have to set the After parameter to the last cell. If you
' have the matching data in the first cell and you set the
' parameter to the first cell (default), it will still be
' found, but a little later (not mili, but micro seconds
' later) so it could be omitted.
' 5. SearchOrder: Whenever a range is a one-row or a one-column range,
' this argument can be omitted. Since you're searching
' in a one-row range, "xlByRows" would have been the
' more 'correct' way in this case.
' 6. SearchDirection: This argument's parameter is by default "xlNext"
' and can therefore be omitted
' 7. MatchCase: This argument's parameter is by default "False". Since
' I don't see the reason why you would have headers with
' the same name, especially the ones you don't need
' before the ones you need, it is omitted. If you really
' need it, use "... xlWhole, , , True".
Set rngName = .Find("Name", .Cells(.Cells.Count), xlValues, xlWhole)
Set rngScore = .Find("Score", .Cells(.Cells.Count), xlValues, xlWhole)
' Address Arguments
' If the Address arguments are omitted, Range.Address returns the
' address as an absolute reference e.g. $A$1. When you split
' $A$1 you will get the following
' INDEX STRING
' 0 - Empty string ("").
' 1 A - Use this i.e. index 1 for the split array index.
' 2 1
If Not rngName Is Nothing Then ' When "Name" was found.
' Calculate Name Column Number.
lngName = rngName.Column
' Calculate Name Column Letter.
strName = Split(rngName.Address, "$")(1)
End If
If Not rngScore Is Nothing Then ' When "Score" was found.
' Calculate Score Column Number.
lngScore = rngScore.Column
' Calculate Score Column Letter.
strScore = Split(rngScore.Address, "$")(1)
End If
Debug.Print "Column Numbers '" & lngName & "' and '" & lngScore & "'."
Debug.Print "Column Letters '" & strName & "' and '" & strScore & "'."
Debug.Print "Name Column Header Address '" & rngName.Address & "'."
Debug.Print "Score Column Header Address '" & rngScore.Address & "'."
With .Parent ' instead of "ThisWorkbook.Worksheets(cSheet)".
'*******************************************************************
' This should demonstrate a case where you don't need the column
' letter (mostly you don't). You should use ".Cells", ".Range" is
' not an option.
'*******************************************************************
' Column Number (lngName)
' Last Row Number calculated using Cells and lngName.
If lngName <> 0 Then
' Calculate last row in Name Column.
lngLR = .Cells(.Rows.Count, lngName).End(xlUp).Row
' Create a reference to the range from First Row to Last Row in
' Name Column.
Set rngName = .Range(.Cells(cFR, lngName), _
.Cells(lngLR, lngName))
End If
'*******************************************************************
' This is the same as the previous and should demonstrate that
' when you already know the column letter, you have two choices:
' you can use ".Cells" or ".Range".
'*******************************************************************
' Column Letter (strName)
' Last Row Number calculated using Cells and strName.
If strName <> "" Then
' Calculate last row in Name Column.
lngLR = .Cells(.Rows.Count, strName).End(xlUp).Row
' Create a reference to the range First Row to Last Row in
' Name Column.
Set rngName = .Range(.Cells(cFR, strName), _
.Cells(lngLR, strName))
End If
' Last Row Number calculated using Range and strName.
If strName <> "" Then
' Calculate last row in Name Column.
lngLR = .Range(strName & .Rows.Count).End(xlUp).Row
' Create a reference to the range from First Row to Last Row in
' Name Column.
Set rngName = .Range(strName & cFR & ":" & strName & lngLR)
End If
'*******************************************************************
' Since the column letter is more user-friendly, the only use
' I can imagine where you might need it, is to inform the user e.g.
MsgBox "Column '" & strName & "' contains the names and column '" _
& strScore & "' contains the scores.", vbInformation, _
"User Information"
End With
Debug.Print "Last (used) Row in Name Column '" & lngLR & "'."
Debug.Print "Name Range Address '" & rngName.Address & "'."
Debug.Print "Column '" & strName & "' contains the Names and column'" _
& strScore & "' contains the scores."
End With
End Sub

Related

Find matching last row and check if the next column row is empty

I have a spreadsheet that includes an ID and a Name. I'd like to have a procedure that (when the user enters a specific ID) will find the most recent instance of that code in the same column, then will check the next column row if its empty. For example:
ID | Name
SD123456 | John
DF989899 | Alice
SD123456 | Jason
KA452331 | Wilson
SD123456 |
DF456790 | Jack
As you can see, the ID 'SD123456' has a missing name, therefore I would like to know if its possible to search for the ID 'SD123456' and get the last row of that ID and check the next column row if its missing. I've tried using xlDown and xlUp but to no avail.
EDIT: In summary, my whole VBA purpose is to search for the ID, then check if that latest ID has a name to it, if not, alert the user that, the ID has a missing name.
You may try this, simple and clear:
Dim lastrow As Long, i As Long
Dim ID As String
lastrow = Sheet1.UsedRange.Rows.Count
ID = "DF989899"
For i = 2 To lastrow
If InStr(Sheet1.Cells(i, 1).Value, ID) And IsEmpty(Sheet1.Cells(i, 2).Value) Then
MsgBox "Missing Value for ID: " & Sheet1.Cells(i, 1).Value
End If
Next
Find the Last Occurrence of a String in a Column
Option Explicit
Sub CheckIDtest()
CheckID "SD123456"
End Sub
Sub CheckID(ByVal ID As String)
' Create references to the ID and Name Column Ranges.
Dim irg As Range, nrg As Range
With Sheet1.Range("A1").CurrentRegion
Set irg = .Columns(1)
Set nrg = .Columns(2)
End With
' Attempt to find the last occurrence of the ID.
Dim fCell As Range
Set fCell = irg.Find(ID, , xlFormulas, xlWhole, , xlPrevious)
' ID was not found.
If fCell Is Nothing Then
MsgBox "The ID '" & ID & "' was not found.", _
vbCritical, "ID Not Found"
Exit Sub
End If
' Write the associated name to a variable.
' This complication allows for the columns not to be adjacent.
Dim fName As String: fName = fCell.EntireRow.Columns(nrg.Column).Value
' If they are adjacent like in this case, you could simplify with...
'fName = fCell.Offset(, 1).Value
' ... and forget about 'nrg'.
If Len(fName) = 0 Then
MsgBox "The Name for the ID '" & ID & "' is missing.", _
vbExclamation, "Missing Name"
Else
MsgBox "The Name for the ID '" & ID & "' is '" & fName & "'.", _
vbInformation, "Name Found"
End If
End Sub

applying formula in the column

I have a formula looking for the column "NAME", adding a blank column after it and naming this new column "word count". Now I need to apply following formula in the new column:
=TRIM(LEN(E2)-LEN(SUBSTITUTE(E2," ","")))+1
Column E is the "NAME" column; however, the location of this column might change from file to file.
Please, try the next code. It searches for the column header "NAME". in the first row of the active sheet and place the formula referencing the found column, in the second column after the found one:
Sub ApplyFormula()
Dim strColName As String, colRng As Range, lastR As Long, colLetter As String
strColName = "NAME" 'the header to search for
'Supposing that the columns headers are in the first row:
Set colRng = ActiveSheet.rows(1).Find(what:=strColName, LookIn:=xlValues, Lookat:=xlWhole)
If Not colRng Is Nothing Then
colLetter = Split(colRng.Address, "$")(1)
lastR = cells(rows.count, colRng.Column).End(xlUp).row
Range(colRng.Offset(1, 2), cells(lastR, colRng.Column + 2)).Formula = _
"=TRIM(LEN(" & colLetter & "2)-LEN(SUBSTITUTE(" & colLetter & lastR & ","" "","""")))+1"
Else
MsgBox "No """ & strColName & """ in the first row..." & vbCrLf & _
"Please, change the row (in the code) or search an existing header.", vbInformation, _
"No such column header..."
End If
End Sub

How to use the ISNULL/empty Function (VBA)

Trying something like this. My code is find the value of cell B7 of Sheet1 in column A of Sheet15. If it is not found, do nothing. If it is found, write the value in the cell next to the found value to the next available cell in column F of Sheet4.
I have this number in Sheet1
Code will find that Sheet1 value in Sheet2 Col"A" then copy the Col"B" value that is "156".
After that code will paste that "156" VALUE IN Sheet3.Range("C2") to till where Col"B" used range end.
Looking forward to your help.
Dim lastR4 As Long
lastR4 = Sheet4.Range("E" & Rows.Count).End(xlUp).Row
If Sheet15.Range("A2:B2") Is Empty Then
Exit Sub
Else
Sheet4.Range("F11:F" & lastR4).Value = Sheet15.Range("A" & _
WorksheetFunction.Match(Sheet1.Range("B7").Value, Sheet15.Range("A:A"), 0)).Offset(0, 1)
End If
Try the next slightly adapted code, please:
Sub testFillDat()
Dim lastR4 As Long
lastR4 = Sheet4.Range("E" & rows.count).End(xlUp).row
If WorksheetFunction.CountA(Sheet15.Range("A2:B2")) = 0 Then
Exit Sub
Else
If Sheet15.Range("B2") = "" Then
Sheet4.Range("F11:F" & lastR4).Value = 0
Else
Sheet4.Range("F11:F" & lastR4).Value = Sheet15.Range("A" & _
WorksheetFunction.match(Sheet1.Range("B7").Value, Sheet15.Range("A:A"), 0)).Offset(0, 1)
End If
End If
End Sub
If there is no match of "B7" (Sheet1) in "A:A" (Sheet15) the code will raise an error. It can be adapted to catch it, but I only tried to show you how checking if a range with multiple cells is empty... In rest, your code should work.
Lookup Using Application.Match
Using Application.Match is easier and cleaner then using WorksheetFunction.Match because you can test the result with IsError or IsNumeric.
The Code
Option Explicit
Sub test()
' The cell containing the lookup value.
Dim cel1 As Range
Set cel1 = Sheet1.Range("B7")
' First 'available' cell in column `E` column, but in column `F`.
Dim cel4 As Range
Set cel4 = Sheet4.Range("E" & Sheet4.Rows.Count).End(xlUp).Offset(1, 1)
' Range from cell `A1` to the last non-empty cell.
Dim rng15 As Range
Set rng15 = Sheet15.Range("A1", Sheet15.Range("A" & Sheet15.Rows.Count).End(xlUp))
' The index of the found value. If not found, returns error value.
' Therefore we use 'Variant'.
Dim cMatch As Variant
cMatch = Application.Match(cel1.Value, rng15, 0)
' Test if found with 'IsNumeric()'. You can also use 'Not IsError()'
' instead. Or even 'IsError()', but then switch the statements.
If IsNumeric(cMatch) Then
cel4.Value = rng15.Cells(cMatch).Offset(, 1).Value
MsgBox "Value '" & cel1.Value & "' copied.", vbInformation, "Success"
Else
MsgBox "Value '" & cel1.Value & "' not found.", vbCritical, "Fail"
End If
End Sub
EDIT
Adjust the sheets and cells appropriately.
Fill Range with Found Value
Sub test2()
' The cell containing the lookup value.
Dim cel1 As Range
Set cel1 = Sheet1.Range("B7")
' Range from cell 'E2' to the last non-empty cell, but column `F`.
Dim rng4 As Range
Set rng4 = Sheet4.Range("E2", Sheet4.Range("E" & Sheet4.Rows.Count) _
.End(xlUp)).Offset(, 1)
' Range from cell `A1` to the last non-empty cell.
Dim rng15 As Range
Set rng15 = Sheet15.Range("A1", Sheet15.Range("A" & Sheet15.Rows.Count) _
.End(xlUp))
' The index of the found value. If not found, returns error value.
' Therefore we use 'Variant'.
Dim cMatch As Variant
cMatch = Application.Match(cel1.Value, rng15, 0)
' Test if found with 'IsNumeric()'. You can also use 'Not IsError()'
' instead. Or even 'IsError()', but then switch the statements.
If IsNumeric(cMatch) Then
rng4.Value = rng15.Cells(cMatch).Offset(, 1).Value
MsgBox "Value '" & cel1.Value & "' copied.", vbInformation, "Success"
Else
MsgBox "Value '" & cel1.Value & "' not found.", vbCritical, "Fail"
End If
End Sub

Inserting value in 2nd cell based on value in 1st cell

I am trying to write a script where as it reads down an entire column starting with E2 and if a cell in that column has a particular value (for this example, let's say A, E, I, O, or U) then it enters a value of "Y" in cell F2, however it continues this pattern until it runs out of filled cells in column E.
I understand the logic of
Dim ColE As String
For ColE = 2 To Rows.Count
Next i
If E1 = "A" Or "E" Or "I" Or "O" Or "U" Then F2 = "Y"
but how do i repeat that say all the way down the entire column of E until it runs out of filled cells in column E
Here is an easy way to implement a list of OR's:
Sub marine()
Dim s1 As String, s2 As String
s1 = "AEIOU"
For i = 2 To 25
If Range("E" & i).Value <> "" Then
If InStr(s1, Range("E" & i).Value) > 0 Then
Range("F" & i).Value = "Y"
End If
End If
Next i
End Sub
Suitable option here is using the select case command with an if-loop
for i = 2 to Cells(Rows.Count, 5).End(xlUp).Row '5 = Column E
Select Case Range("E"&i).value
Case "A", "E", "I", "O", "U"
Range("F"&i).value
End Select
next
Using Select Case allows you to also give different commands for other inputs in column E and is way easier to handle than if-conditions for your specific requirements.
Cells(Rows.Count, 5).End(xlUp).Row '5
This will return the row number of the last entry in the fifth column (column E). You can use it in the for-loop to iterate until the very last row.
Search Multiple Criteria
Copy the code into a standard module (e.g. Module1).
Carefully adjust the values in the constants section.
The Code
Option Explicit
Sub searchMultipleCriteria()
' Handle Errors
Const Proc = "searchMultipleCriteria"
On Error GoTo cleanError
' Define constants.
Const SheetName As String = "Sheet1"
Const FirstRow As Long = 2
Const CriteriaCol As Variant = "E" ' 1 or "A"
Dim CriteriaVals As Variant: CriteriaVals = Array("A", "E", "I", "O", "U")
Const ResultCol As Variant = "F" ' 1 or "A"
Const ResultVal As String = "Y"
Dim wb As Workbook: Set wb = ThisWorkbook
' Write values from Criteria Column Range to Criteria Array.
Dim ws As Worksheet: Set ws = wb.Worksheets(SheetName)
Dim rng As Range
Set rng = ws.Columns(CriteriaCol).Find("*", , xlFormulas, , , xlPrevious)
If rng Is Nothing Then GoTo EmptyColumn
If rng.Row < FirstRow Then GoTo NoRange
Set rng = ws.Range(ws.Cells(FirstRow, CriteriaCol), rng)
Dim Criteria As Variant: Criteria = rng.Value
' Write values from Result Column Range to Result Array.
Set rng = rng.Offset(, ws.Columns(ResultCol).Column - rng.Column)
Dim Result As Variant: Result = rng.Value
' Modify values in Result Array.
Dim i As Long, Curr As Variant
For i = 1 To UBound(Criteria)
' Note: 'Match' is not case-sensitive i.e. A=a...
Curr = Application.Match(Criteria(i, 1), CriteriaVals, 0)
If Not IsError(Curr) Then
Result(i, 1) = ResultVal
Else ' Maybe you wanna do something here...
'Result(i, 1) = "N"
End If
Next i
' Write values from Result Array to Result Range.
rng.Value = Result
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
' Revert Settings (not utilized in this Sub)
CleanExit:
Exit Sub
' Not As Planned
EmptyColumn:
MsgBox "Looking in an empty column to define a range with values!?", _
vbExclamation, "'" & Proc & "': Empty Column"
GoTo CleanExit
NoRange:
MsgBox "Trying to define a range with an ending row lower than " _
& "the starting row!?", _
vbExclamation, "'" & Proc & "': No Range"
GoTo CleanExit
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'!" & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description, _
vbCritical, "'" & Proc & "': Unexpected Error"
On Error GoTo 0
GoTo CleanExit
End Sub

Concatenate two columns and skip blank cells

My current spreadsheet has two columns of data I would like to concatenate. In my provided code, I create a column to the right of the columns I would like to combine and then use a FOR loop to combine each value with a ", " between the values. I would like to adjust the code to skip cells/rows without values because now I end up with a ", " in my combined column if the two initial columns had no values.
Public Sub MergeLatLong()
Dim LastRow As Long
Worksheets("Raw_Data").Activate
Columns("AT:AT").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
LastRow = Range("AR" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Cells(i, 46) = Cells(i, 44) & ", " & Cells(i, 45)
Next i
End Sub
Do you need to use VBA? I would recommend using a TEXTJOIN formula (if you have Excel 2016). Assuming your cells in columns AR and AS and the formula in AT.
The parameters for the formula are =TEXTJOIN(delimiter,ingnore_blanks,range)
So the below formula in AT1 would return a concatenation of the two columns for each row with a comma as the delimiter if there is contents in both columns.
=TEXTJOIN(“,”,TRUE,AR1:AS1)
If you are using a version less than 2016. You could just use the following
=AR1&IF(ISBLANK(AS1),””,”, AS1”)
Either of these can be dragged down and you wouldn’t have any extra commas in any rows with a blank in column AS.
The code below should do what you intend. It will enter a blank if both values are missing, the first only (without comma) if the second is missing, and the second only (with leading comma) if the first is missing. You might adjust that part to better suit your needs.
Public Sub MergeLatLong()
Dim Ws As Worksheet
Dim LastRow As Long
Dim Combo As String, Tmp As String
Dim R As Long
' No need to Activate or Select anything!
Set Ws = Worksheets("Raw_Data")
With Ws
.Columns(46).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
LastRow = .Cells(Rows.Count, "AR").End(xlUp).Row
For R = 2 To LastRow
' if you mean the 'Value' it's better to specify the 'Value' property
Combo = Trim(.Cells(R, 44).Value) ' treat Space as blank
Tmp = Trim(.Cells(R, 45).Value) ' treat Space as blank
If Len(Tmp) Then Tmp = ", " & Tmp
If Len(Combo) And Len(Tmp) > 0 Then Combo = Combo & Tmp
Cells(R, 46).Value = Combo
Next R
End With
End Sub
As did #Dude Scott, I also felt that a worksheet function might be more suitable. VBA might have some advantage if it's a very frequently recurring task only.
If the number of entries is large, add Application.ScreenUpdating = False before the For .. Next loop and reset ScreenUpdating to True at the end of the procedure. That will make for significantly better speed.
you could loop through column AR not blank cells only and check for column AS ones content to properly add comma
moreover, avoid Activate/Select pattern and use direct and explicit reference to ranges:
Public Sub MergeLatLong()
Dim cell As Range
With Worksheets("Raw_Data") ' reference wanted worksheet
.Columns("AT:AT").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
For Each cell In .Range("AR2", .Cells(.Rows.Count, "AR").End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced sheet column AR cells with some "constant" values
If IsEmpty(cell.Offset(, 1)) Then
cell.Offset(, 2) = cell.Value
Else
cell.Offset(, 2) = cell.Value & ", " & cell.Offset(, 1)
End If
Next
End With
End Sub
2 Columns 2 One
Fast Array Version
Sub MergeLatLong() ' Array Version
Dim vnt1 As Variant ' 1st Array
Dim vnt2 As Variant ' 2nd Array
Dim vntR As Variant ' Result Array
Dim NoR As Long ' Number of Rows
Dim i As Long ' Row Counter
Dim str1 As String ' 1st String
Dim str2 As String ' 2nd String
Dim strR As String ' Result String
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle possible error.
On Error GoTo ErrorHandler
With ThisWorkbook.Worksheets("Raw_Data")
' Insert column ("AT") to the right of column ("AS").
.Columns("AT").Insert xlToRight, xlFormatFromLeftOrAbove
' Calculate Number of Rows (Last Used Row - First Row + 1).
NoR = .Cells(.Rows.Count, "AR").End(xlUp).Row - 2 + 1
' Copy values of column "AR" to 1st Array.
vnt1 = .Columns("AR").Cells(2).Resize(NoR)
' Copy values of column "AS" to 2nd Array.
vnt2 = .Columns("AS").Cells(2).Resize(NoR)
End With
' Resize Result Array to size of 1st Array (or 2nd Array).
ReDim vntR(1 To UBound(vnt1), 1 To 1) As String
' Remarks: All arrays are of the same size.
' Loop through rows of arrays.
For i = 1 To NoR
' Write current value in 1st array to 1st String.
str1 = vnt1(i, 1)
' Write current value in 2nd array to 2nd String.
str2 = vnt2(i, 1)
' Check if 1st String is not empty ("").
If str1 <> "" Then ' 1st String is not empty.
' Check if 2nd String is not empty ("").
If str2 <> "" Then ' 2nd String is not empty.
' Concatenate.
strR = str1 & ", " & str2
Else ' 2nd String is empty.
strR = str1
End If
Else ' 1st String is empty.
If str2 <> "" Then ' 2nd String is not empty.
strR = str2
Else ' 2nd String is empty.
strR = ""
End If
End If
' Write Result String to current row of Result Array.
vntR(i, 1) = strR
Next
With ThisWorkbook.Worksheets("Raw_Data").Columns("AT")
' Copy Result Array to Result Range.
.Cells(2).Resize(NoR) = vntR
' Adjust the width of Result Column.
.AutoFit
' ' Apply some additional formatting to Result Range.
' With .Cells(2).Resize(NoR)
' ' e.g.
' .Font.Bold = True
' End With
End With
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error has occurred. Error '" & Err.Number & "': " _
& Err.Description, vbInformation, "Error"
GoTo ProcedureExit
End Sub
Slow Range Version
Sub MergeLatLongRange() ' Range Version
Dim LastRow As Long ' Last Row Number
Dim i As Long ' Row Counter
Dim str1 As String ' 1st String
Dim str2 As String ' 2nd String
Dim strR As String ' Result String
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle possible error.
On Error GoTo ErrorHandler
With ThisWorkbook.Worksheets("Raw_Data")
' Insert column ("AT") to the right of column ("AS").
.Columns("AT").Insert xlToRight, xlFormatFromLeftOrAbove
' Calculate Last Used Row using 1st column "AR".
LastRow = .Cells(.Rows.Count, "AR").End(xlUp).Row
' Loop through rows in columns.
For i = 2 To LastRow
' Write value of cell at current row in column "AR" to 1st String.
str1 = .Cells(i, "AR")
' Write value of cell at current row in column "AS" to 2nd String.
str2 = .Cells(i, "AS")
' Check if 1st String is not empty ("").
If str1 <> "" Then ' 1st String is not empty.
' Check if 2nd String is not empty ("").
If str2 <> "" Then ' 2nd String is not empty.
' Concatenate.
strR = str1 & ", " & str2
Else ' 2nd String is empty.
strR = str1
End If
Else ' 1st String is empty.
If str2 <> "" Then ' 2nd String is not empty.
strR = str2
Else ' 2nd String is empty.
strR = ""
End If
End If
' Write Result String to cell at current row in column "AT".
Cells(i, "AT") = strR
Next
' Adjust the width of column "AT".
.Columns("AT").AutoFit
End With
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error has occurred. Error '" & Err.Number & "': " _
& Err.Description, vbInformation, "Error"
GoTo ProcedureExit
End Sub
Here is the code I ended up using, a blend of the responses above. I create some additional code to find the columns with latitude and longitude, that way if the columns were to somehow be rearranged, the program would still be looking at the correct columns for values.
Sub concatenateLatLong()
Dim WS As Worksheet
Dim lastRow As Long
Dim longName As String
Dim longColumn As Long
Dim latName As String
Dim latColumn As Long
Dim latValue As String
Dim longValue As String
Dim i As Long
Set WS = Worksheets("Data")
With WS
lastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
'MsgBox "The last row with entered data is " & lastRow
'Find Longitude column
longName = "LONGITUDE"
longColumn = .Rows(1).Find(What:=longName, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
'MsgBox "The " & longName & " header is found in column " & longColumn
'Insert a row to the right of the longitude column
.Columns(longColumn + 1).Insert Shift:=xlToLeft, CopyOrigin:=xlFormatFromLeft
'Give new column header "LAT, LONG"
.Cells(1, longColumn + 1).Value = "LAT, LONG"
'Find Latitude column
latName = "LATITUDE"
latColumn = .Rows(1).Find(What:=latName, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
'MsgBox "The " & latName & " header is found in column " & latColumn
'Combine latitude and longitude
For i = 2 To lastRow
latValue = Trim(.Cells(i, latColumn).Value)
longValue = Trim(.Cells(i, longColumn).Value)
If Len(longValue) Then longValue = ", " & longValue
If Len(latValue) And Len(longValue) > 0 Then latValue = latValue & longValue
.Cells(i, longColumn + 1).Value = latValue
Next i
End With
End Sub

Resources