Excel VBA: Delete multiple columns using variable containing column numbers - vba

Because of the high chances of the arrangement of columns being adjusted in my raw data, I want to store the column numbers in variables.
I think that my syntax Columns(Variable_name) is wrong, but can't figure what will work
I tried Columns("Variable_name") which didn't work too.
Set Cws = Worksheets.Add
Cws.Name = "Ready_For_Send"
Dim Region As Integer: Region = 1
Dim Sub_Region As Integer: Sub_Region = 2
Dim User_Status As Integer: User_Status = 5
Dim Count As Integer: Count = 15
With Cws
.Range(.Columns(Region) & "," & .Columns(Sub_Region) & "," & .Columns(User_Status) & "," & Columns(Count)).Delete
End With

You can use the following:
With Cws
.Range(Cells(1, Region).EntireColumn.Address & "," _
& Cells(1, Sub_Region).EntireColumn.Address & "," _
& Cells(1, User_Status).EntireColumn.Address & "," _
& Cells(1, Count).EntireColumn.Address).Delete
End With

You can use the Union to merge all your columns to one Range, and then delete it.
Try the code below:
Dim DelRng As Range
With Cws
' Set a new range from all the columns you want to delete
Set DelRng = Union(.Columns(Region), .Columns(Sub_Region), .Columns(User_Status), .Columns(Count))
DelRng.Delete
End With

May be something like this:
Option Explicit
Sub DeleteCols()
Dim wb As Workbook
Dim Csw As Worksheet
Dim Region As Long
Dim Sub_Region As Long
Dim User_Status As Long
Dim Count As Long
Dim Cws As Worksheet
Region = 1
Sub_Region = 2
User_Status = 5
Count = 15
Set wb = ThisWorkbook
Application.DisplayAlerts = False
On Error Resume Next
Set Cws = wb.Worksheets.Add
Cws.Name = "Ready_For_Send"
On Error GoTo 0
Application.DisplayAlerts = True
With Cws
.Range( _
ReturnName(Region) & ":" & ReturnName(Region) & "," & _
ReturnName(Sub_Region) & ":" & ReturnName(Sub_Region) & "," & _
ReturnName(User_Status) & ":" & ReturnName(User_Status) & "," & _
ReturnName(Count) & ":" & ReturnName(Count) _
).Delete Shift:=xlToLeft
End With
End Sub
Function ReturnName(ByVal num As Integer) As String
ReturnName = Split(Cells(, num).Address, "$")(1)
End Function
Some structure and Function from here: Delete multiple columns
I have included error handling in case sheet already exists. Also full declarations. I have also put declarations and assignments on different lines for ease of reading.

Related

My reconciliation VBA macro takes too long to run when the data is in the thousands

I have a task that requires me to reconcile two sheets of data. I have reformatted them both to have the same format from Column A to M and use the below code to run the reconciliation
It is fine when the data is small but when it gets to thousands of lines, it took 30 min just to run. Is there a way to optimize this code?
The idea is reconcile 2 worksheets then all the matched data go to the 'Matched' worksheet and the unmatched goes to the unmatched worksheet
Dim report_exLR As Long
Dim report_inLR As Long
Dim report_exrng As Range
Dim report_inrng As Range
Set ws_rexternal = ThisWorkbook.Worksheets("Reformat External")
Set ws_rinternal = ThisWorkbook.Worksheets("Reformat Internal")
Set ws_unmatched = ThisWorkbook.Worksheets("Unmatched")
Set ws_matched = ThisWorkbook.Worksheets("Matched")
ex_LR = ws_rexternal.Cells(Rows.Count, 2).End(xlUp).Row
in_LR = ws_rinternal.Cells(Rows.Count, 2).End(xlUp).Row
'concatenate all relevant criteria into one column
For a = 2 To ex_LR
ws_rexternal.Range("T" & a) = ws_rexternal.Range("A" & a) & "," & ws_rexternal.Range("B" & a) & "," & ws_rexternal.Range("C" & a) & "," & ws_rexternal.Range("D" & a) & "," & ws_rexternal.Range("E" & a) & "," & ws_rexternal.Range("F" & a) & "," & ws_rexternal.Range("G" & a) & "," & ws_rexternal.Range("H" & a) & "," & ws_rexternal.Range("I" & a) & "," & ws_rexternal.Range("J" & a) & "," & ws_rexternal.Range("K" & a) & "," & ws_rexternal.Range("L" & a) & "," & ws_rexternal.Range("M" & a)
Next a
For b = 2 To ex_LR
ws_rinternal.Range("T" & b) = ws_rexternal.Range("A" & b) & "," & ws_rexternal.Range("B" & b) & "," & ws_rexternal.Range("C" & b) & "," & ws_rexternal.Range("D" & b) & "," & ws_rexternal.Range("E" & b) & "," & ws_rexternal.Range("F" & b) & "," & ws_rexternal.Range("G" & b) & "," & ws_rexternal.Range("H" & b) & "," & ws_rexternal.Range("I" & b) & "," & ws_rexternal.Range("J" & b) & "," & ws_rexternal.Range("K" & b) & "," & ws_rexternal.Range("L" & b) & "," & ws_rexternal.Range("M" & b)
Next b
'start reconciliation
For a = 2 To ex_LR
For b = 2 To in_LR
If ws_rexternal.Range("T" & a) = ws_rinternal.Range("T" & b) Then
ws_rexternal.Range(Cells(a, 1).Address, Cells(a, 14).Address).Copy Destination:=ws_matched.Range(Cells(a, 1).Address, Cells(a, 14).Address)
ws_rinternal.Range(Cells(b, 1).Address, Cells(b, 14).Address).Copy Destination:=ws_matched.Range(Cells(a, 16).Address, Cells(a, 30).Address)
ws_matched.Cells(a, 15).Value = "Matched"
ws_matched.Cells(a, 15).Interior.Color = RGB(0, 255, 0)
ws_rexternal.Rows(a).ClearContents
ws_rinternal.Rows(b).ClearContents
End If
Next b
Next a
'reformat the unmatched and matched
For d = ex_LR To 1 Step -1
Set ex_Row = ws_rexternal.Rows(d)
If WorksheetFunction.CountA(ex_Row) = 0 Then
ws_rexternal.Rows(d).Delete
End If
Next d
For e = in_LR To 1 Step -1
Set in_Row = ws_rinternal.Rows(e)
If WorksheetFunction.CountA(in_Row) = 0 Then
ws_rinternal.Rows(e).Delete
End If
Next e
report_exLR = ws_rexternal.Cells(Rows.Count, 2).End(xlUp).Row
report_inLR = ws_rinternal.Cells(Rows.Count, 2).End(xlUp).Row
Set report_exrng = ws_rexternal.Range("A1:A" & report_exLR)
report_exrng.EntireRow.Copy ws_unmatched.Cells(1, 1)
Set report_inrng = ws_rinternal.Range("A1:A" & report_inLR)
report_inrng.EntireRow.Copy ws_unmatched.Cells(ex_LR, 1).Offset(5, 0)
End Sub
Ok this is probably a lot more complex than it needs to be, but it seems to work OK.
It would be much simpler to just flag the data in-place as matched/unmatched, with a pointer to the matching row on the other sheet.
Sub FormatExcel()
Dim report_exLR As Long, ws_rexternal As Worksheet, ws_unmatched As Worksheet
Dim report_inLR As Long, ws_rinternal As Worksheet, ws_matched As Worksheet
Dim report_exrng As Range, report_inrng As Range
Dim rngInt As Range, rngExt As Range, k, rw As Range, t, rwMatch As Long
Dim rngIntKeys As Range, rngExtKeys As Range, m, rng As Range, n As Long
Dim rngUnmatchedInt As Range, rngUnmatchedExt As Range
Setup
t = Timer
With ThisWorkbook
Set ws_rexternal = .Worksheets("Reformat External")
Set ws_rinternal = .Worksheets("Reformat Internal")
Set ws_unmatched = .Worksheets("Unmatched")
Set ws_matched = .Worksheets("Matched")
End With
'clear previous data
ws_unmatched.Cells.Clear
ws_matched.Cells.Clear
'source data ranges
Set rngInt = ws_rinternal.Range("A2:M" & ws_rinternal.Cells(Rows.Count, 2).End(xlUp).Row)
Set rngExt = ws_rexternal.Range("A2:M" & ws_rexternal.Cells(Rows.Count, 2).End(xlUp).Row)
'speed up copy/paste
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'generate all keys for Internal rows in ColT
For Each rw In rngInt.Rows
rw.EntireRow.Columns("T").Value = RowKey(rw)
Next rw
Set rngIntKeys = rngInt.EntireRow.Columns("T") 'range with keys
Debug.Print "Generated keys", Timer - t
rwMatch = 1
For Each rw In rngExt.Rows
If rw.Row Mod 100 = 0 Then Debug.Print "Row: " & rw.Row, Timer - t
m = Application.Match(RowKey(rw), rngIntKeys, 0)
If Not IsError(m) Then 'got match on "internal" sheet?
rwMatch = rwMatch + 1
rw.Copy ws_matched.Cells(rwMatch, "A")
ws_matched.Cells(rwMatch, "N").Value = "Matched"
rngInt.Rows(m).Copy ws_matched.Cells(rwMatch, "P")
rngIntKeys.Cells(m).ClearContents 'remove matched key from T
Else
BuildRange rngUnmatchedExt, rw 'collect unmatched external row
End If
Next rw
Debug.Print "Copied matches", Timer - t
'copy unmatched external
If Not rngUnmatchedExt Is Nothing Then
rngUnmatchedExt.Copy ws_unmatched.Range("A1")
End If
'copy unmatched internal
Set rngIntKeys = rngInt.EntireRow.Columns("T")
For n = 1 To rngExt.Rows.Count
If Len(rngIntKeys.Cells(n).Value) > 0 Then
BuildRange rngUnmatchedInt, rngExt.Rows(n)
End If
Next n
If Not rngUnmatchedInt Is Nothing Then
rngUnmatchedInt.Copy _
ws_unmatched.Cells(ws_unmatched.UsedRange.Rows.Count + 5, 1)
End If
Debug.Print "Copied non-matches", Timer - t
Application.Calculation = xlCalculationAutomatic
End Sub
'generate a "key" by concatenating all cell values in `rng` with "|"
Function RowKey(rng As Range) As String
RowKey = Join(Application.Transpose(Application.Transpose(rng.Value)), "|")
End Function
'build up a range from sub-ranges
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
For completeness here's the sub I used to reset the sheets and create sample data:
'reset the sheets and create some sample data
Sub Setup()
Const ROWSN As Long = 1000 '# of rows to create
Const RNDV As String = "=ROUND(rand()*5,0)" 'adjust to change chance of matched rows
Dim ws_rexternal As Worksheet, ws_unmatched As Worksheet
Dim ws_rinternal As Worksheet, ws_matched As Worksheet
With ThisWorkbook
Set ws_rexternal = .Worksheets("Reformat External")
Set ws_rinternal = .Worksheets("Reformat Internal")
Set ws_unmatched = .Worksheets("Unmatched")
Set ws_matched = .Worksheets("Matched")
End With
'clar all sheets
ws_unmatched.Cells.Clear
ws_matched.Cells.Clear
ws_rexternal.Cells.Clear
ws_rinternal.Cells.Clear
'ws_rexternal.Range ("A2:M1000")
With ws_rexternal.Range("A2:C2").Resize(ROWSN)
.Formula = RNDV
.Value = .Value
End With
ws_rexternal.Range("D2:M2").Resize(ROWSN).Value = "blah"
With ws_rinternal.Range("A2:C2").Resize(ROWSN)
.Formula = RNDV
.Value = .Value
End With
ws_rinternal.Range("D2:M2").Resize(ROWSN).Value = "blah"
End Sub

Search workbook and extract data without opening it excel vba

I have some vba code to open excel files based on the filename-date (i.e. "test-09Sep2016.xlsm".
After the file is opened, it searches through the workbook and attempts to find what I'm looking for. Once it returns the results, it will close the workbook and loop through the folder to find the next file and so forth....
The issue is that the file size is massive and opening the file takes quite a while, i'm wondering if there is a way to do so without opening the actual file.
My current code is below:
Sub firstCoord()
Dim fpath As String, fname As String
Dim dateCount As Integer, strDate As Date
Dim i As Integer, j As Integer, k As Integer, lastRow As Integer, lastRow2 As Integer
Dim ws As Worksheet, allws As Worksheet
Dim seg As String
Dim strNum As String
Dim strRow As Integer
lastRow = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
seg = Mid(ThisWorkbook.Name, 34, 1)
With Application.WorksheetFunction
For i = 2 To lastRow
fpath = "_______\"
strDate = Sheet1.Range("B" & i)
strNum = seg & Format(Mid(Sheet1.Range("A" & i), 4, 3), "000") & "000"
dateCount = 0
Do While Len(Dir(fpath & "_____-" & Format(strDate - dateCount, "ddmmmyyyy") & ".xlsx")) = 0 And dateCount < 35
dateCount = dateCount + 1
Loop
fname = "____-" & Format(strDate - dateCount, "ddmmmyyyy") & ".xlsx"
Workbooks.Open (fpath & fname)
For Each ws In Workbooks(fname).Worksheets
If ws.Name Like "*all*" Then
Set allws = Workbooks(fname).Worksheets(ws.Name)
ws.Activate
End If
Next ws
lastRow2 = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
ThisWorkbook.Activate
k = 1
Do While (.CountIf(Sheet1.Range("C" & i & ":" & "E" & i), "") <> 0 Or Sheet1.Range("F" & i) = "") And k <= lastRow2
If Left(allws.Range("A" & k), 7) = strNum Then
Sheet1.Range("C" & i) = allws.Range("D" & k)
Sheet1.Range("D" & i) = allws.Range("C" & k)
Sheet1.Range("E" & i) = allws.Range("E" & k)
ElseIf k = lastRow2 And Sheet1.Range("C" & i) = "" Then
Sheet1.Range("F" & i) = "Not Found"
End If
k = k + 1
Loop
Workbooks(fname).Close
Next i
End With
End Sub
Any help would be greatly appreciated!!
Thanks
It is possible to retrieve data from Excel without opening the file using adodb, but you must (as far as I know) know at least the first column/row and last column of the dataset in the target file. You do not need to know the last row.
For example, this code calls two separate procedures, one that returns the value from a single cell and one that returns the value of the first cell in the defined range, from a closed workbook named GetDataInClosedWB:
Sub Main()
Call GetDataFromSingleCell("A1")
Call GetDataFromRangeBlock("A2", "D")
End Sub
Sub GetDataFromSingleCell(cell As String)
Dim CN As Object ' ADODB.Connection
Dim RS As Object ' ADODB.Recordset
Set CN = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & CStr("C:\Users\USERNAME\Desktop\GetDataInA1.xlsx") & _
";" & "Extended Properties=""Excel 12.0;HDR=No;"";"
RS.Open "SELECT * FROM [Sheet1$" & cell & ":" & cell & "];", CN, 3, 1 'adOpenStatic, adLockReadOnly
MsgBox (RS.Fields(0).Value)
End Sub
Sub GetDataFromRangeBlock(firstCell As String, lastCol As String)
'firstCell is the upper leftmost cell in the target range
'lastCol is the column reference (e.g. A,B,C,D...) of the last column in the
'target dataset
Dim CN As Object ' ADODB.Connection
Dim RS As Object ' ADODB.Recordset
Set CN = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & CStr("C:\Users\USERNAME\Desktop\GetDataInA1.xlsx") & _
";" & "Extended Properties=""Excel 12.0;HDR=No;"";"
RS.Open "SELECT * FROM [Sheet1$" & firstCell & ":" & lastCol & "];", CN, 3, 1 'adOpenStatic, adLockReadOnly
MsgBox (RS.Fields(0).Value)
End Sub
The GetDataInClosedWB file has the value Hello World! in A1 and values FirstHeader, SecondHeader, ThirdHeader, and FourthHeader in range A2:D2, respectively. The first procedure returns Hello World! in a message box, and the second return FirstHeader in a message box.
Once you've loaded the data into a Recordset you can iterate through it and perform your logic.
Note: if you prefer early binding, you'll need to enable a reference to a Microsoft ActiveX Data Objects Library.

Need a real VBA equivalent for Excel Value function

As mentioned in the title, I need a VBA equivalent to the Excel Value function. My data set looks like this: Data set example
What I am looking for is VBA code equivalent to this: =Value(A2)+Value(B2). That would go in column C
The output must be the same as that function. For the given example, column C should end up looking like this: End product
More than that, it needs to only have the value in the cell after the macro is run, rather than displaying the value and still having that formula in it.
Here is what I have done so far:
For i = 1 To LastRow
strValue = Val(sht.Range("A" & i))
strValue1 = Val(sht.Range("B" & i))
sht.Range("C" & i).Value = strValue + strValue1
Next i
I also tried variations on this, a couple of which are shown below:
For i = 1 To LastRow
strValue = Evaluate(sht.Range("A" & i))
strValue1 = Evaluate(sht.Range("B" & i))
sht.Range("C" & i).Value = strValue + strValue1
Next i
For i = 1 To LastRow
strValue = sht.Range("A" & i)
strValue1 = sht.Range("B" & i)
strVal = Evaluate(strValue)
strVal1 = Evaluate(strValue1)
sht.Range("C" & i).Value = strVal + strVal1
Next i
I can't find anything that will work for me. The output in C for the example set ends up being just 9. Pretty sure it is taking the first number in A and adding it to the first number in B. So when the hour in B changes to 1 C displays 10.
I also tried simply:
For i=1 To LastRow
sht.Range("C" & i).Value = sht.Range("A" & i).Value + sht.Range("B" & i).Value
Next i
That just concatenated the text to the format 9/03/15 00:00:00
Any and all help appreciated. Bonus if you can point me in the right direction for changing the final C values from that number (ie. 42250.00017) to the custom date/time format 'yyyy-mm-dd hh:mm:ss'.
Edit: Here is my code up to the sticking point. Everything else works as I want it to, the only problem is with the last For loop.
Sub sbOrganizeData()
Dim i As Long
Dim k As Long
Dim sht As Worksheet
Dim LastRow As Long
Dim sFound As String
Dim rng As Range
Dim sheet As Worksheet
Dim Sheet2 As Worksheet
Dim strFile As String
Dim strCSV As String
Dim strValue As Double
Dim strValue1 As Double
Dim strVal As Long
Dim strVal1 As Long
Application.DisplayAlerts = False
Sheets("all016").Delete
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
Set sheet = Sheets.Add
Set Sheet2 = Sheets.Add
sheet.Name = "all016"
Sheet2.Name = "Sheet1"
strFile = ActiveWorkbook.Path
strCSV = "*.csv"
sFound = Dir(strFile & "\*.csv")
If sFound <> "" Then
Workbooks.Open Filename:=strFile & "\" & sFound
End If
Range("A1").CurrentRegion.Copy Destination:=Workbooks("solar.xlsm").Sheets("all016").Range("A1")
Workbooks(sFound).Close
Set sht = ThisWorkbook.Sheets("all016")
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
sht.Range("C1").EntireColumn.Insert
For i = 1 To LastRow
'Code that doesn't quite work here'
sht.Range("C" & i).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Next i
The issue is that the dates and times are strings so something like this will work:
For i = 2 To LastRow
strValue = Evaluate("VALUE(TRIM(" & sht.Range("A" & i).Address(1,1,,1) & "))")
strValue1 = Evaluate("VALUE(TRIM(" & sht.Range("B" & i).Address(1,1,,1) & "))")
sht.Range("C" & i).Value = strValue + strValue1
'the format
sht.Range("C" & i).NumberFormat = "mm/dd/yy hh:mm:ss"
Next i
You have to reference the .Value2 field of the range element as:
For i = 1 To LastRow
sht.Range("C" & i).Value2 = sht.Range("A" & i).Value2 + sht.Range("B" & i).Value2
Next i
The value is free of formatting and just in Excel's time/date code as you want your final result to be. Cheers,

How do I get all the different unique combinations of 3 columns using VBA in Excel?

I have an Excel worksheet with several columns, where 3 of them form a "unique key".
If I have fruits in column A (Apple, Banana, Orange), some name in column B (John, Peter) and something like Yes/No in column C, I want to be able to get sums of values from rows where the values in these columns are the same.
For instance, the sum of all the values in column D for rows where columns A, B and C are Apple,John,Yes.
Sorry for the confusing text, but I don't know how to express my question more clearly. I've never done anything in VBA so I'm a bit lost here...
Here's an example of the expected result.
It is also possible to go to the data tab -> remove duplicates. You can then select which columns you would like to compare in removing the dulicates.
I don't know in advance which combinations exist. The goal is to list all the unique combinations and the sum of some other columns. Can I do this without using VBA?
No Formulas/VBA required. Use a Pivot table for a summary of all combinations. See screenshot
If you still want VBA then that can also be done :)
EDIT
I quickly wrote this
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub

macro to check non blank cells in a column to ensure isdate()

I've been looking to write a macro to check 3 columns to ensure the contents are a date value. The columns can contain empty cells.
The below returns a message box for each cell that is not a date, even the blanks.
Sub DateCheck()
With ActiveSheet
lastRow = .Range("AB" & Rows.Count).End(xlUp).Row
For RowCount = 2 To lastRow
POC = .Range("AB" & RowCount)
If Not IsDate(POC) Then
MsgBox ("Please enter valid date in Cell : AB" & RowCount & ". Example: dd/mm/yyyy")
End If
Next RowCount
End With
End Sub
Could anybody be so kind as to help to adjust this to look at 3 non-adjacent columns, ignore blank cells and only return one message per column in the event it finds non-date values?
Thanks as always
Chris
Code:
Sub DateCheck()
Dim s(2) As String
Dim i As Integer
Dim o As String
Dim lastRow As Long
Dim r As Long
'Enter columns here:
s(0) = "A"
s(1) = "B"
s(2) = "C"
For i = 0 To 2
With ActiveSheet
lastRow = .Range(s(i) & Rows.Count).End(xlUp).Row
For r = 2 To lastRow
POC = .Range(s(i) & r)
If Not IsDate(POC) Then
o = o & ", " & .Range(s(i) & r).Address
End If
Next r
MsgBox ("Please enter valid date in Cells : " & Right(o, Len(o) - 1) & ". Example: dd/mm/yyyy")
o = ""
End With
Next i
End Sub
I would change your loop to a For Each In ... Next and use .Union to construct a range of non-adjacent columns.
Sub MultiDateCheck()
Dim lr As Long, cl As Range, rng As Range, mssg As String
With ActiveSheet
lr = .Range("AB" & Rows.Count).End(xlUp).Row
Set rng = Union(.Range("AB2:AB" & lr), .Range("AM2:AM" & lr), .Range("AZ2:AZ" & lr))
For Each cl In rng
If Not IsDate(cl.Value) And Not IsEmpty(cl) Then _
mssg = mssg & cl.Address(0, 0) & Space(4)
Next cl
End With
If CBool(Len(mssg)) Then
MsgBox ("Please enter valid date(s) in Cell(s): " & Chr(10) & Chr(10) & _
mssg & Chr(10) & Chr(10) & _
"Example: dd/mm/yyyy")
Else
MsgBox "All dates completed!"
End If
Set rng = Nothing
End Sub
I've used a single lastrow from column AB to determined the scope of the cells to be examined but individual rows for each column could easily be compensated for.
Addendum: Code modified for a single message showing rogue non-date/non-blank cells (as below). The Chr(10) is simply a line feed character.